Con la finalidad de facilitar codigos fuentes a los programadores del foro, creo este post, en donde iremos poniendo unicamente codigos fuentes en Visual Basic 6.
Si alguien tiene alguno simplemente lo postea.
En lo posible en caso de ser un poco confuso o largo el codigo, poner una breve descripcion de lo que hace el codigo y recuerde editar el titulo con el nombre del code.
Fuentes y creditos: Forosdelweb - Recursosvisualbasic
Saludos a todos.
Copy Paste de un post de antrax en un foro hermano, espero que no le moleste :P
Incluir este code en el programa para que se ejecute una sola vez
Private Sub Form_Load()
Dim Ya_Existe As Integer
Ya_Existe = App.PrevInstance
If Ya_Existe <> 0 Then
MsgBox "El Programa ya se esta ejecutando", 0 + 48, "News"
End
End If
End Sub
Como usar el Random en un programa
Código:
Private Sub Form_Load()
Dim Num As Double
Randomize
Num = Rnd
MsgBox Num
End Sub
Saber desde que directorio se ejecuta mi aplicación
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
Como verificar si un fichero existe
Código:
Public Sub VerificarFichero(sNombreFichero As String)
On Error Resume Next
Open sNombreFichero For Input As #1
If Err Then
MsgBox ("El fichero " & sNombreFichero & " no existe.")
Exit Sub
End If
Close #1
End Sub
en un botton:
VerificarFichero "c:\prueba.txt"
Código:
Dim Archivo As String
Archivo = "C:\MiTexto.txt"
If Dir(Archivo, vbArchive) = "" Then
MsgBox "El Fichero No Existe"
End If
Como ingresar solo numeros en un campo de texto
Código:
If ((KeyAscii < 48 Or KeyAscii > 57) And (KeyAscii < 44 Or KeyAscii > 44)) Then
If (KeyAscii <> 8) Then KeyAscii = 0
End If
Como dar vuelta a un texto
Vamos a imaginar que por el motivo que sea deseamos invertir el orden de los caracteres de un texto. Imaginemos que el texto lo tenemos en una variable llamada Texto y almacenamos el contenido de la caneda texto al inverso en la variable Otxet. Por ejemplo: si tenemos el texto Casa obtendremos asaC.
Para ello deberíamos escribir el siguiente código:
Código:
For Contador = Len(Texto) To 1 Step -1
Otxet = Otxet & Mid (Texto, Contador, 1)
Next Contador
Como pasar de un texto a otro usando Enter
Insertar tres TextBox y escribir el siguiente código:
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:
Código:
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Usar IF THEN ELSE ENDIF en una misma línea
Insertar un CommandButton y un TextBox y escribir el siguiente código:
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
Una variante del mismo codigo:
Insertar un CommandButton y un TextBox y escribir el siguiente código:
Código:
Private Sub Command1_Click()
Dim I As Integer
Dim A As String
I = 3
If I <> 1 Then A = "True" Else A = "False"
Text1.Text = A
End Sub
Convertir un texto a mayúsculas o minúsculas
Código:
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
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:
Código:
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
Leer y escribir un fichero Ini
Declaraciones generales en un módulo:
Código:
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
'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).
Hacer sonar un fichero Wav o Midi
Insertar el siguiente código en un módulo:
Código:
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
Compactar una base de datos, usando código VB
Este es el código que uso para compactar las bases de datos. Cosa que suelo hacer bastante a menudo, sobre todo en las que uso en la empresa, que cambian a diario.
Por aquello de la seguridad, mantengo dos copias: la anterior y la última. Más vale prevenir. Nunca se sabe cuando se cortará la luz o se quedará colgado el equipo... así que, me curo en salud.
Código:
'Cerrar la base (esto sólo si la tienes abierta...)
Db.Close
'Liberar memoria y "desligarla"
Set Db = Nothing
'
'Tomar el nombre sin la extensión
sTmp = ""
i = InStr(NombreBase, ".")
If i Then
p = i - 1
Else
p = Len(NombreBase)
End If
sTmp = Left$(NombreBase, p)
'Buscar \, para tomar el directorio (path)
For i = p To 1 Step -1
If Mid$(NombreBase, i, 1) = "\" Then
sTmp = Left$(NombreBase, i)
Exit For
End If
Next
If Right$(sTmp, 1) <> "\" Then
sTmp = sTmp & "\"
End If
'Todo este proceso es para estar seguro de que se quede una copia
'en caso de que falle la compactación...
dBaseTmp = sTmp & "~dBase2.mdb"
If Len(Dir$(dBaseTmp)) Then Kill dBaseTmp
If Len(Dir$(sTmp & "~dBase1.mdb")) Then Kill sTmp & "~dBase1.mdb"
'Esta es la madre del cordero, se pueden usar otras "versiones", es cuestión de adecuarte.
CompactDatabase NombreBase, dBaseTmp, dbLangSpanish, dbVersion20
'Guardar una copia de como estaba antes
Name NombreBase As sTmp & "~dBase1.mdb"
'Esta es la base ya compactada, así que asignar el nombre
Name dBaseTmp As NombreBase
'Borrar los ficheros LDB
If Len(Dir$(sTmp & "*.ldb")) Then Kill sTmp & "*.ldb"
Cómo imprimir un MSFLEXGRID
Código:
Public Sub MSHFG_Print(ByVal gri As Control, cabecer As String, peu As String)
Set grid = gri
ReDim dimen(grid.Cols)
If grid.Rows = 1 Then Exit Sub
'Agafo l'amplada del grid total a imprimir
ample = 0
For x = 0 To grid.Cols - 1
grid.Col = x
If grid.CellWidth > 20 Then
If grid.CellWidth < 200 Then grid.ColWidth(x) = 200
ample = grid.CellWidth + ample
End If
dimen(x) = grid.CellWidth
Next x
grid.LeftCol = 1
'ja tinc el ample a imprimir
tppx = Printer.TwipsPerPixelX
tppy = Printer.TwipsPerPixelY
cabecera = cabecer
pie = peu
x0 = (Printer.ScaleWidth - ample) / 2
y0 = (Printer.Height - Printer.ScaleHeight) / 2
y1 = y0
Printer.CurrentY = y1
grid.Col = 0
grid.Row = 0
For Row = 0 To grid.Rows - 1
If Row = 0 Then PosCapMSHFG
'faig la ultima linea del grid si ha acabat sense cuadricular
If Printer.ScaleHeight - 1500 < y1 Then 'finalitzo pag i poso capçelera.
If cuadro = True Then Printer.Line (x0, y1)-(x0 + ample, y1), vbBlack, B
Printer.CurrentY = Printer.ScaleHeight - 500
Printer.CurrentX = x0
Printer.Print pie
Printer.CurrentX = Printer.ScaleWidth - 1000
Printer.Print "Pág " & Printer.Page
Printer.NewPage
PosCapMSHFG
End If
ImpLinMSHFG
Next
'faig la ultima linea del grid si ha acabat sense cuadricular
If cuadro = True Then Printer.Line (x0, y1)-(x0 + ample, y1), vbBlack, B
Printer.CurrentY = Printer.ScaleHeight - 500
Printer.CurrentX = x0
Printer.Print pie
Printer.CurrentX = Printer.ScaleWidth - 1000
Printer.Print "Pág " & Printer.Page
Printer.EndDoc
End Sub
Private Sub ImpLinMSHFG()
alt = grid.RowHeight(Row)
Printer.FillStyle = 1 'solido 0
Printer.CurrentX = x0
Printer.CurrentY = y1 'printer.CurrentY - tppy
If cuadro Then
Printer.Line -Step(ample + tppx, alt + tppy), vbBlack, B
Else
Printer.Line (x0 + ample, y1)-(x0 + ample, y1 + alt + tppy), vbBlack, B
End If
cuadro = Not cuadro
For Col = 0 To grid.Cols - 1
If Col = 0 Then
x1 = x0 'COMENÇO PER L'ESQUERRA
'alt = printer.FontSize * tppy * 5
Else
x1 = x1 + dimen(Col - 1)
End If
If dimen(Col) < 20 Then Col = Col + 1
If dimen(Col) > 20 Then
Printer.CurrentX = x1 + tppx
Printer.CurrentY = y1 '+ tppy
Printer.Line (x1, y1 + tppy)-(x1, alt + y1 - tppy), vbBlack, B
Printer.CurrentX = x1 + 30 / tppx
Printer.CurrentY = y1 '+ tppy
texte = grid.TextArray(grid.Cols * Row + Col)
Do While Printer.TextWidth(texte) > dimen(Col) And Len(texte) > 0
texte = Left(texte, Len(texte) - 1)
punts = True
Loop
If punts = True And Len(texte) > 0 Then texte = Left(texte, Len(texte) - 2) & "..."
punts = False
If grid.ColAlignment(Col) > 5 Then Printer.CurrentX = Printer.CurrentX + dimen(Col) - Printer.TextWidth(texte) - 30 / tppx
If grid.ColAlignment(Col) >= 3 And grid.ColAlignment(Col) <= 5 Then Printer.CurrentX = Printer.CurrentX + (dimen(Col) - Printer.TextWidth(texte)) / 2
Printer.Print texte
End If
Next
y1 = y1 + grid.RowHeight(Row) '- tppy 'y + alto de la fila actual
End Sub
Public Sub PosCapMSHFG()
Printer.CurrentY = y0
Printer.FontSize = 20
Printer.ForeColor = vbBlue
Printer.FontBold = True
Printer.CurrentX = (Printer.Width - Printer.ScaleWidth) + (Printer.ScaleWidth - Printer.TextWidth(cabecera)) / 2
Printer.Print cabecera
Printer.FontSize = 8.25
Printer.ForeColor = vbBlack
Printer.FontBold = False
y1 = Printer.CurrentY + 300 'separaciò amb el titol
'Row = trow
'grid.Row = Row
'grid.Col = 0
For Col = 0 To grid.Cols - 1
'grid.Col = Col
If Col = 0 Then
x1 = x0 'COMENÇO PER L'ESQUERRA
'alt = printer.FontSize * tppy * 5
Else
x1 = x1 + dimen(Col - 1)
End If
If dimen(Col) < 20 Then Col = Col + 1
'If grid.Col = 9 Or grid.Col = 11 Then x1 = x1 + 400
'grid.Col = Col
If dimen(Col) > 20 Then
Printer.CurrentX = x1 + tppx
Printer.CurrentY = y1 '+ tppy
Printer.Line (x1, y1 + tppy)-(x1, alt + y1 - tppy), vbBlack, B
Printer.CurrentX = x1 + 15 / tppx
Printer.CurrentY = y1 '+ tppy
texte = grid.TextArray(Col)
Do While Printer.TextWidth(texte & "...") > dimen(Col) And Len(texte) > 0
texte = Left(texte, Len(texte) - 1)
punts = True
Loop
If punts = True And Len(texte) > 0 Then texte = Left(texte, Len(texte) - 2) & "..."
punts = False
Printer.CurrentX = Printer.CurrentX + (dimen(Col) - Printer.TextWidth(texte)) / 2
Printer.Print texte
End If
Next
y1 = y1 + grid.RowHeight(Row) '- tppy 'y + alto de la fila actual
cuadro = True
If Row = 0 Then Row = 1
End Sub
Dibujar Codigo de Barras (Bar Code)
El codigo a continuación tiene un Procedimiento llamado
DrawBarCode, el cual recibe el codigo del item, la descripción del mismo y un control PictureBox, el cual contendrá el codigo de barras.
Sólo debes diseñar un form con 3 controles (2 textBox y 1 PictureBox), luego
ejecutas
Call DrawBarcode(codigo_item, Descripcion_item, PictureBox)
Código:
Sub DrawBarcode(ByVal bc_string As String, sDescripcion As String, VLPrecio as String, obj As Control)
Dim xpos!, y1!, y2!, dw%, th!, tw, new_string$
Dim bc(90) As String
Dim sAux As String
Dim I As Byte
bc(1) = "1 1221" 'pre-amble
bc(2) = "1 1221" 'post-amble
bc(48) = "11 221" 'dígitos
bc(49) = "21 112"
bc(50) = "12 112"
bc(51) = "22 111"
bc(52) = "11 212"
bc(53) = "21 211"
bc(54) = "12 211"
bc(55) = "11 122"
bc(56) = "21 121"
bc(57) = "12 121"
'Letras Mayúsculas
bc(65) = "211 12" 'A
bc(66) = "121 12" 'B
bc(67) = "221 11" 'C
bc(68) = "112 12" 'D
bc(69) = "212 11" 'E
bc(70) = "122 11" 'F
bc(71) = "111 22" 'G
bc(72) = "211 21" 'H
bc(73) = "121 21" 'I
bc(74) = "112 21" 'J
bc(75) = "2111 2" 'K
bc(76) = "1211 2" 'L
bc(77) = "2211 1" 'M
bc(78) = "1121 2" 'N
bc(79) = "2121 1" 'O
bc(80) = "1221 1" 'P
bc(81) = "1112 2" 'Q
bc(82) = "2112 1" 'R
bc(83) = "1212 1" 'S
bc(84) = "1122 1" 'T
bc(85) = "2 1112" 'U
bc(86) = "1 2112" 'V
bc(87) = "2 2111" 'W
bc(88) = "1 1212" 'X
bc(89) = "2 1211" 'Y
bc(90) = "1 2211" 'Z
'Misceláneos Caracteres
bc(32) = "1 2121" 'Espacio
bc(35) = "" '# no se puede realizar
bc(36) = "1 1 1 11" '$
bc(37) = "11 1 1 1" '%
bc(43) = "1 11 1 1" '+
bc(45) = "1 1122" '-
bc(47) = "1 1 11 1" '/
bc(46) = "2 1121" '.
bc(64) = "" '@ no se puede realizar
bc(65) = "1 1221" '*
bc_string = UCase(bc_string) 'Convertir a mayúsculas
'Dimensiones
obj.ScaleMode = 2 'Pixeles
obj.Cls
obj.Picture = Nothing
dw = CInt(obj.ScaleHeight / 40) 'Espacio entre barras
If dw < 1 Then dw = 1
th = obj.TextHeight(bc_string) 'Alto texto
tw = obj.TextWidth(bc_string) 'Ancho texto
new_string = Chr$(1) & bc_string & Chr$(2) 'Agregar pre-amble, post-amble
y1 = obj.ScaleTop + 12
y2 = obj.ScaleTop + obj.ScaleHeight - 1.5 * th
obj.Width = 1.1 * Len(new_string) * (15 * dw) * obj.Width / obj.ScaleWidth
'Dibujar cada caracter en el string barcode
xpos = obj.ScaleLeft
For n = 1 To Len(new_string)
c = Asc(Mid(new_string, n, 1))
If c > 90 Then c = 0
bc_pattern$ = bc(c)
'Dibujar cada barra
For I = 1 To Len(bc_pattern$)
Select Case Mid(bc_pattern$, I, 1)
Case " "
'Espacio
obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
xpos = xpos + dw
Case "1"
'Espacio
obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
xpos = xpos + dw
'Línea
obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &H0&, BF
xpos = xpos + dw
Case "2"
'Espacio
obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
xpos = xpos + dw
'Ancho línea
obj.Line (xpos, y1)-(xpos + 2 * dw, y2), &H0&, BF
xpos = xpos + 2 * dw
End Select
Next
Next
'Mas espacio
obj.Line (xpos, y1)-(xpos + 1 * dw, y2), &HFFFFFF, BF
xpos = xpos + dw
'Medida final y tamaño
obj.Width = (xpos + dw) * obj.Width / obj.ScaleWidth
obj.CurrentX = 1
obj.CurrentY = 1
If VLPrecio = "0.00" Then VLPrecio = ""
If xpos - obj.TextWidth(VLPrecio) - 10 < obj.TextWidth(sDescripcion) Then
sAux = ""
For I = 1 To Len(sDescripcion)
If xpos - obj.TextWidth(VLPrecio) - 10 < obj.TextWidth(sAux) Then
Exit For
Else
sAux = sAux & Mid(sDescripcion, I, 1)
End If
Next I
obj.Print sAux
Else
obj.Print sDescripcion
End If
obj.CurrentX = xpos - obj.TextWidth(VLPrecio)
obj.CurrentY = 1
obj.Print VLPrecio
obj.CurrentX = (obj.ScaleWidth - tw) / 2
obj.CurrentY = y2 + 0.25 * th
obj.Print bc_string
'Copiar a clipboard
obj.Picture = obj.Image
Clipboard.Clear
Clipboard.SetData obj.Image, 2
End Sub
Como Guardar datos en el registro de Windows
Hola. Create un formulario llamado Form1, y en el pon un CheckBox, llamado Check1. Depués añade este código.
Código:
Private Sub Form_Load()
Check1.Value = GetSetting(App.Title, Form1.Name, Check1.Name, vbChecked)
End Sub
Código:
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, Form1.Name, Check1.Name, Check1.Value
End Sub
Tendrás que hacer lo mismo con cada uno de los controles de tu formulario.
Se podría hacer incluso un procedimiento para guardar en un bucle todas las propiedades de todos los controles de un formulario, pero eso te lo dejamos investigar a vos.
en caso de que fuera un texto un label se reemplaza el codigo por las propiedades de un texto, por ejemplo
Código:
Private Sub Form_Load()
text1.text = GetSetting(App.Title, Form1.Name, text1.name, vbChecked)
End Sub
Código:
Private Sub Form_Unload(Cancel As Integer)
SaveSetting App.Title, Form1.Name, text1.name, text1.text
End Sub
para una label seria igual pero con label1.caption..
Como Utilizar un ProgressBar
Una barra del progreso exhibe una barra azul creciente o que se contrae para dar la regeneración de usuario en una cierta clase de operación. Esto puede descargar un archivo del Internet o de la terminación de una tarea muy larga. La barra azul puede ser dividida en segmentos o puede ser sólida. El ProgressBar está situado en los controles comunes de Microsoft Windows así que agregar este control a su caja de herramientas que usted tiene que chascar encendido proyectos sobre la barra de menú, después chascar encendido componentes y los componentes caja aparecerá de diálogo, después enrollan abajo y localizan los controles 6 del campo común de Microsoft Windows y ponen un cheque en la caja de cheque al lado de ella y chascan encendido MUY BIEN.
* Nota: CTRL + t también abre la caja de diálogo de los componentes
Características, métodos y acontecimientos
características significativas
Movimiento en sentido vertical(Scrolling): se determina si la exhibición del progreso aparece sólida o dividida en segmentos
Negotiate: esto se determina si un control que puede ser alineado está exhibido cuando un objeto activo en la forma exhibe unos o más toolbars.
Orientación( Orientación): se determina si la orientación es horizontal o vertical
Valor(Value): el ajuste actual de la barra del progreso
Aspecto(Appearance): esto hace que la barra del progreso aparece o en 3D o plano
BorderStyle: fija el estilo de la frontera de los controles
Max, Min: fija los valores máximos y mínimos de la barra del progreso
Métodos las barras del progreso hacen que los métodos estándares de otros controles éstos incluyan el movimiento, tecleo, DblClick etcétera.
Ejemplo:
Coloque simplemente una barra del progreso en la pantalla fijada su característica mínima a 0 y su característica máxima a 100. Experimente entre las dos diversas características de Scolling del ccScrollingSmooth (normal) o del ccScrollingStandard (dividido en segmentos). Para animar la barra del progreso ponga un control del contador de tiempo(Timer) en la forma y fije su característica del intervalo a 1000 milisegundos que el Now agrega un botón de comando a la forma (el usuario chascará esto y la barra del progreso se moverá), hace que los botones de comando subtitulan dice algo como comienzo.
Primero ponga el código siguiente en el procedimiento del acontecimiento del Form Load.
Código:
Private Sub Form_Load()
Timer1.Enabled = False
ProgressBar1.Value = 0
End Sub
Ahora ponga el código siguiente en el procedimiento del acontecimiento del Command buttons Click
Código:
Private Sub Command1_Click()
ProgressBar1.Value = 0
Timer1.Enabled = True
End Sub
y finalmente el código siguiente consigue colocado en el acontecimiento del contador de tiempo de los contadores de tiempo
Código:
Private Sub Timer1_Timer()
ProgressBar1.Value = ProgressBar1.Value + 1
If ProgressBar1.Value >= 10 Then _
Timer1.Enabled = False
End Sub
Manual de como bloquear CTRL+ALT+SUP, ALT+TAB, Y OTROS WinXP
CTRL+ALT+SUP (TaskManager)
Se debe ingresar la instrucción "DisableTaskMgr" directamente en el regedit con el valor "1" en la carpeta abajo indicada, esto es fácil hacerlo desde VB.
[HKEY_CURRENT_USER\Software\Microsoft\Windows\Curre ntVersion\Policies\System]
Value Name: DisableTaskMgr
Data Type: REG_DWORD (DWORD Value)
Value Data: (0 = default, 1 = bloquea Task Manager)
------------------------------------------------------------------
ALT+TAB, CTRL+ESC (Tecla Windows), ALT+F4
Crear el siguiente Módulo (.BAS), no importa como le llamen
Código:
Option Explicit
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Const HC_ACTION = 0
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_SYSKEYDOWN = &H104
Public Const WM_SYSKEYUP = &H105
Public Const WH_KEYBOARD_LL = 13
Public Type KBDLLHOOKSTRUCT
vkCode As Long
scanCode As Long
flags As Long
time As Long
dwExtraInfo As Long
End Type
Public Enum VirtualKey
VK_LBUTTON = &H1
VK_RBUTTON = &H2
VK_CTRLBREAK = &H3
VK_MBUTTON = &H4
VK_BACKSPACE = &H8
VK_TAB = &H9
VK_ENTER = &HD
VK_SHIFT = &H10
VK_CONTROL = &H11
VK_ALT = &H12
VK_PAUSE = &H13
VK_CAPSLOCK = &H14
VK_ESCAPE = &H1B
VK_SPACE = &H20
VK_PAGEUP = &H21
VK_PAGEDOWN = &H22
VK_END = &H23
VK_HOME = &H24
VK_LEFT = &H25
VK_UP = &H26
VK_RIGHT = &H27
VK_DOWN = &H28
VK_PRINTSCREEN = &H2C
VK_INSERT = &H2D
VK_DELETE = &H2E
VK_0 = &H30
VK_1 = &H31
VK_2 = &H32
VK_3 = &H33
VK_4 = &H34
VK_5 = &H35
VK_6 = &H36
VK_7 = &H37
VK_8 = &H38
VK_9 = &H39
VK_A = &H41
VK_B = &H42
VK_C = &H43
VK_D = &H44
VK_E = &H45
VK_F = &H46
VK_G = &H47
VK_H = &H48
VK_I = &H49
VK_J = &H4A
VK_K = &H4B
VK_L = &H4C
VK_M = &H4D
vk_n = &H4E
VK_O = &H4F
VK_P = &H50
VK_Q = &H51
VK_R = &H52
VK_S = &H53
VK_T = &H54
VK_U = &H55
VK_V = &H56
VK_W = &H57
VK_X = &H58
VK_Y = &H59
VK_Z = &H5A
VK_LWINDOWS = &H5B
VK_RWINDOWS = &H5C
VK_APPSPOPUP = &H5D
VK_NUMPAD_0 = &H60
VK_NUMPAD_1 = &H61
VK_NUMPAD_2 = &H62
VK_NUMPAD_3 = &H63
VK_NUMPAD_4 = &H64
VK_NUMPAD_5 = &H65
VK_NUMPAD_6 = &H66
VK_NUMPAD_7 = &H67
VK_NUMPAD_8 = &H68
VK_NUMPAD_9 = &H69
VK_NUMPAD_MULTIPLY = &H6A
VK_NUMPAD_ADD = &H6B
VK_NUMPAD_PLUS = &H6B
VK_NUMPAD_SUBTRACT = &H6D
VK_NUMPAD_MINUS = &H6D
VK_NUMPAD_MOINS = &H6D
VK_NUMPAD_DECIMAL = &H6E
VK_NUMPAD_POINT = &H6E
VK_NUMPAD_DIVIDE = &H6F
VK_F1 = &H70
VK_F2 = &H71
VK_F3 = &H72
VK_F4 = &H73
VK_F5 = &H74
VK_F6 = &H75
VK_F7 = &H76
VK_F8 = &H77
VK_F9 = &H78
VK_F10 = &H79
VK_F11 = &H7A
VK_F12 = &H7B
VK_NUMLOCK = &H90
VK_SCROLL = &H91
VK_LSHIFT = &HA0
VK_RSHIFT = &HA1
VK_LCONTROL = &HA2
VK_RCONTROL = &HA3
VK_LALT = &HA4
VK_RALT = &HA5
VK_POINTVIRGULE = &HBA
VK_ADD = &HBB
VK_PLUS = &HBB
VK_EQUAL = &HBB
VK_VIRGULE = &HBC
VK_SUBTRACT = &HBD
VK_MINUS = &HBD
VK_MOINS = &HBD
VK_UNDERLINE = &HBD
VK_POINT = &HBE
VK_SLASH = &HBF
VK_TILDE = &HC0
VK_LEFTBRACKET = &HDB
VK_BACKSLASH = &HDC
VK_RIGHTBRACKET = &HDD
VK_QUOTE = &HDE
VK_APOSTROPHE = &HDE
End Enum
Dim p As KBDLLHOOKSTRUCT
Public Function LowLevelKeyboardProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim fEatKeystroke As Boolean
If (nCode = HC_ACTION) Then
If wParam = WM_KEYDOWN Or wParam = WM_SYSKEYDOWN Or wParam = WM_KEYUP Or wParam = WM_SYSKEYUP Then
CopyMemory p, ByVal lParam, Len(p)
fEatKeystroke = _
(p.vkCode = VK_CAPSLOCK) Or _
(p.vkCode = VK_LWINDOWS) Or _
(p.vkCode = VK_RWINDOWS) Or _
(p.vkCode = VK_APPSPOPUP) Or _
((p.vkCode = VK_SPACE) And ((GetKeyState(VK_ALT) And &H8000) <> 0)) Or _
((p.vkCode = VK_TAB) And ((GetKeyState(VK_ALT) And &H8000) <> 0)) Or _
((p.vkCode = VK_ESCAPE) And ((GetKeyState(VK_CONTROL) And &H8000) <> 0))
End If
End If
If fEatKeystroke Then
LowLevelKeyboardProc = -1
Else
LowLevelKeyboardProc = CallNextHookEx(0, nCode, wParam, ByVal lParam)
End If
End Function
Es mucho texto, sugiero Copiar y Pegar.
Para bloquear en cualquier momento se debe escribir la sigueinte setencia:
Código:
hhkLowLevelKybd = SetWindowsHookEx(WH_KEYBOARD_LL, AddressOf LowLevelKeyboardProc, App.hInstance, 0)
Para desbloquear (ojo, esto es importantísimo, si no hay que resetear la máquina), se digita la siguiente sentencia:
Código:
UnhookWindowsHookEx hhkLowLevelKybd
Para bloquear y ocultar la barra de tareas (TaskBar)
En otro módulo (.BAS) digitar:
Código:
Global Const SW_HIDE = 0
Global Const SW_SHOWNORMAL = 1
Global Const SW_SHOW = 5
Public Declare Function FindWindowHandle Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Para que se ejecute las funciones escribir las siguientes sentencias:
Código:
Dim hWnd As Long
Dim Res As Long
hWnd = FindWindowHandle("shell_traywnd", Chr(0))
Res = ShowWindow(hWnd, SW_HIDE)
Y para desbloquear y mostrar de nuevo:
Código:
hWnd = FindWindowHandle("shell_traywnd", Chr(0))
Res = ShowWindow(hWnd, SW_SHOW)
Por último para minimizar todas las ventanas incluso si están en modo gráfico como juegos,
En un módulo (.BAS) digitar lo siguiente:
Código:
Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, _
ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Public Const VK_LWIN = &H5B
Public Const KEYEVENTF_KEYUP = &H2
Para que se ejecute el proceso dar las siguientes instrucciones:
Código:
Call keybd_event(VK_LWIN, 0, 0, 0)
Call keybd_event(&H4D, 0, 0, 0)
Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)
Tipos de Conexiones a Bases de Datos en Visual Basic
Bueno por alli yo investigando he econtrado estos tipos de conexiones
SQL Server
ODBC
Standard Security:
"Driver={SQL Server};Server=Aron1;Database=pubs;Uid=sa;Pwd=asda sd;"
Trusted connection:
"Driver={SQL Server};Server=Aron1;Database=pubs;Trusted_Connect ion=yes;"
Prompt for username and password:
oConn.Properties("Prompt") = adPromptAlways
oConn.Open "Driver={SQL Server};Server=Aron1;DataBase=pubs;"
Access
ODBC
Standard Security:
"Driver={Microsoft Access Driver (*.mdb)};Dbq=C:\mydatabase.mdb;Uid=Admin;Pwd=;"
Workgroup:
"Driver={Microsoft Access Driver (*.mdb)};Dbq=C:\mydatabase.mdb;SystemDB=C:\mydatab ase.mdw;"
Exclusive:
"Driver={Microsoft Access Driver (*.mdb)};Dbq=C:\mydatabase.mdb;Exclusive=1;Uid=adm in;Pwd="
Oracle
ODBC
New version:
"Driver={Microsoft ODBC for Oracle};Server=OracleServer.world;Uid=Username;Pwd =asdasd;"
Old version:
"Driver={Microsoft ODBC Driver for Oracle};ConnectString=OracleServer.world;Uid=myUse rname;Pwd=myPassword;"
MySQL
ODBC
Local database:
"Driver={mySQL};Server=mySrvName;Option=16834;Data base=mydatabase;"
Remote database:
"Driver={mySQL};Server=data.domain.com;Port=3306;O ption=131072;Stmt=;Database=my-database;Uid=username;Pwd=password;"
Interbase
ODBC, Easysoft
Local computer:
"Driver={Easysoft IB6 ODBC};Server=localhost;Database=localhost:C:\mydat abase.gdb;Uid=username;Pwd=password"
Remote Computer:
"Driver={Easysoft IB6 ODBC};Server=ComputerName;Database=ComputerName:C: \mydatabase.gdb;Uid=username;Pwd=password"
ODBC, Intersolv
Local computer:
"Driver={INTERSOLV InterBase ODBC Driver (*.gdb)};Server=localhost;Database=localhost:C:\my database.gdb;Uid=username;Pwd=password"
Remote Computer:
"Driver={INTERSOLV InterBase ODBC Driver (*.gdb)};Server=ComputerName;Database=ComputerName :C:\mydatabase.gdb;Uid=username;Pwd=password"
Sybase
ODBC
Standard Sybase System 12 (or 12.5) Enterprise Open Client:
"Driver={SYBASE ASE ODBC Driver};Srvr=Aron1;Uid=username;Pwd=password"
Standard Sybase System 11:
"Driver={SYBASE SYSTEM 11};Srvr=Aron1;Uid=username;Pwd=password;"
Intersolv 3.10:
"Driver={INTERSOLV 3.10 32-BIT Sybase};Srvr=Aron1;Uid=username;Pwd=password;"
Sybase SQL Anywhere (former Watcom SQL ODBC driver):
"ODBC; Driver=Sybase SQL Anywhere 5.0; DefaultDir=c:\dbfolder\;Dbf=c:\mydatabase.db;Uid=u sername;Pwd=password;Dsn="""""
Informix
ODBC
Informix 3.30:
"Dsn='';Driver={INFORMIX 3.30 32 BIT};Host=hostname;Server=myserver;Service=service-name;Protocol=olsoctcp;Database=mydb;UID=username; PWD=myPwd
Informix-CLI 2.5:
"Driver={Informix-CLI 2.5 (32 Bit)};Server=myserver;Database=mydb;Uid=username;P wd=myPwd"
Mimer SQL
ODBC
Standard Security:
"Driver={MIMER};Database=mydb;Uid=myuser;Pwd=mypw; "
Prompt for username and password:
"Driver={MIMER};Database=mydb;"
DSN
ODBC
DSN:
"DSN=myDsn;Uid=username;Pwd=;"
File DSN:
"FILEDSN=c:\myData.dsn;Uid=username;Pwd=;"
Excel
ODBC
Standard:
"Driver={Microsoft Excel Driver (*.xls)};DriverId=790;Dbq=C:\MyExcel.xls;DefaultDi r=c:\mypath;"
Text
ODBC
Standard:
"Driver={Microsoft Text Driver (*.txt; *.csv)};Dbq=c:\txtFilesFolder\;Extensions=asc,csv, tab,txt;"
DBF / FoxPro
ODBC
standard:
"Driver={Microsoft dBASE Driver (*.dbf)};DriverID=277;Dbq=c:\mydbpath;"
Visual FoxPro
ODBC
Database container (.DBC):
"Driver={Microsoft Visual FoxPro Driver};SourceType=DBC;SourceDB=c:\myvfpdb.dbc;Exc lusive=No;Collate=Machine;"
Free Table directory:
"Driver={Microsoft Visual FoxPro Driver};SourceType=DBF;SourceDB=c:\myvfpdbfolder;E xclusive=No;Collate=Machine;"
Pervasive
ODBC
Standard:
"Driver={Pervasive ODBC Client Interface};ServerName=srvname;dbq=@dbname"
OLE DB
Standard:
"Provider=PervasiveOLEDB;Data Source=C:\path"
UDL
UDL
UDL:
"File Name=c:\myDataLink.udl;"
como Imprimir en tamaño especial en Impresoras Matriciales e
bueno yo tope con lo mismo y pedi soporte a Epson.es y me respondieron esto para las impresoras matriciales en windows XP con tamaño de papel "No", standar.
Para XP.
1. Acceda desde el botón INICIO (CONFIGURACIÓN) carpeta IMPRESORAS (Y
FAXES).
2. Seleccione el icono del driver haciendo un clic con el botón izquierdo
marcando el icono de la impresora EPSON.
3. Busque en el menú ARCHIVO la opción PROPIEDADES DEL SERVIDOR.
4. En la pestaña FORMULARIOS, active la casilla de verificación CREAR UN
NUEVO FORMULARIO.
5. Encontrará un cuadro de texto que dice DESCRIPCIÓN DEL FORMULARIO
(Medidas)
6. En este campo escriba un nombre que identifique su papel por ejemplo
NUEVO_FORMULARIO:
7. En el área MEDIDAS encontrará dos cuadros de valores que corresponderán a
la ANCHURA y ALTURA del formulario
que vaya a utilizar, si tiene seleccionado el botón MÉTRICO introduzca los
valores en centímetros.
8. Una vez introduzca las medidas tanto de altura como de anchura, pulse
sobre el botón GUARDAR FORMULARIO para
grabarlo y a partir de ese momento le aparecerá en la lista de la ventana
superior donde se puede escoger el papel
por defecto para esa impresora.
9. A continuación pulse sobre el botón ACEPTAR y le aparecerá para escoger
el nuevo papel NUEVO_FORMULARIO. En la
carpeta de impresoras, pulse el botón derecho del ratón sobre el icono de su
impresora, entre en 'Configuración predeterminada para este documento' y en
la pestaña de avanzadas, seleccione el tamaño de papel personalizado que
hemos creado.
Recuerde que es muy importante además de crear el formulario, definir en
la propia aplicación desde donde se
desea imprimir, el tamaño físico del formulario que deberá coincidir con las
medidas de NUEVO_FORMULARIO.
Solo numeros en un Texbox
Código:
Function SoloNumeros(ByVal KeyAscii As Integer) As Integer
' Intercepta un codigo ASCII recibido admitiendo solamente
' caracteres numéricos, además:
' cambia el punto por una coma
' acepta el signo -
' deja pasar sin afectar si recibe tecla de borrado o return
If KeyAscii = Asc(".") Then KeyAscii = Asc(",")
If InStr("0123456789.,-", Chr(KeyAscii)) = 0 Then
SoloNumeros = 0
Else
SoloNumeros = KeyAscii
End If
' teclas especiales permitidas
If KeyAscii = 8 Then SoloNumeros = KeyAscii borrado atras
End Function
Private Sub txtvalor_KeyPress(KeyAscii As Integer)
KeyAscii = SoloNumeros(KeyAscii)
End Sub
Otra Forma Para Ingresar Solo Numeros
Código:
Private Sub Text1_LostFocus()
If Not IsNumeric(Me.Text1.Text) Then
MsgBox ("Ingrese solo numeros")
End If
End Sub
Como saber cuantos registros tiene el Recordset
Ustedes diran "¡Qué fácil! Usamos la propiedad RecordCount del Recordset" ..... Si y no. La propiedad RecordCount funciona bien si antes nos movemos hasta el último registro, sino, en algunos casos funciona y en otros no. Pero si nuestro recordset no tiene registros, no puede ejecutar el RS.MoveLast, ya que no tiene registros, y el programa da un error. Entonces podemos hacer lo siguiente:
Código:
If RS.EOF = True And RS.BOF = True Then
MsgBox "Nuestro Recordset no tiene registros"
else
RS.MoveLast
MsgBox "Nuestro Recordset tiene " & CStr(RS.RecordCount) & " registros
End If
Si el Recordset no tiene registros, tanto la propiedad EOF como la BOF tiene valor verdadero.
Imprimir un RichTextBox tal y como se ve
Imprimir un RichTextBox con su formato original.
Código:
Private Sub Command1_Click()
On Error GoTo ErrorDeImpresion
Printer.Print ""
RichTextBox1.SelPrint Printer.hDC
Printer.EndDoc
Exit Sub
ErrorDeImpresion:
Exit Sub
End Sub
Otra forma:
En el Formulario [Form1 por defecto] :
Código:
Private Sub Form_Load() Dim LineWidth As Long Me.Caption = "Rich Text Box Ejemplo de Impresion" Command1.Move 10, 10, 600, 380 Command1.Caption = "&Imprimir" RichTextBox1.SelFontName = "Verdana, Tahoma, Arial" RichTextBox1.SelFontSize = 10 LineWidth = WYSIWYG_RTF(RichTextBox1, 1440, 1440) Me.Width = LineWidth + 200End Sub Private Sub Form_Resize() RichTextBox1.Move 100, 500, Me.ScaleWidth - 200, Me.ScaleHeight - 600End Sub Private Sub Command1_Click() PrintRTF RichTextBox1, 1440, 1440, 1440, 1440End Sub Crear un módulo y escribir:
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type CharRange
cpMin As Long
cpMax As Long
End Type
Private Type FormatRange
hdc As Long
hdcTarget As Long
rc As Rect
rcPage As Rect
chrg As CharRange
End Type
Private Const WM_USER As Long = &H400
Private Const EM_FORMATRANGE As Long = WM_USER + 57
Private Const EM_SETTARGETDEVICE As Long = WM_USER + 72
Private Const PHYSICALOFFSETX As Long = 112
Private Const PHYSICALOFFSETY As Long = 113
Private Declare Function GetDeviceCaps Lib "gdi32" ( _
ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "USER32" Alias "SendMessageA" _
(ByVal hWnd As Long, ByVal msg As Long, ByVal wp As Long, lp As Any) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As Long, ByVal lpInitData As Long) As Long
Public Function WYSIWYG_RTF(RTF As RichTextBox, LeftMarginWidth As Long, _
RightMarginWidth As Long) As Long
Dim LeftOffset As Long, LeftMargin As Long, RightMargin As Long
Dim LineWidth As Long
Dim PrinterhDC As Long
Dim r As Long
Printer.Print Space(1)
Printer.ScaleMode = vbTwips
LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
LeftMargin = LeftMarginWidth - LeftOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
LineWidth = RightMargin - LeftMargin
PrinterhDC = CreateDC(Printer.DriverName, Printer.DeviceName, 0, 0)
r = SendMessage(RTF.hWnd, EM_SETTARGETDEVICE, PrinterhDC, _
ByVal LineWidth)
Printer.KillDoc
WYSIWYG_RTF = LineWidth
End Function
Public Sub PrintRTF(RTF As RichTextBox, LeftMarginWidth As Long, _
TopMarginHeight, RightMarginWidth, BottomMarginHeight)
Dim LeftOffset As Long, TopOffset As Long
Dim LeftMargin As Long, TopMargin As Long
Dim RightMargin As Long, BottomMargin As Long
Dim fr As FormatRange
Dim rcDrawTo As Rect
Dim rcPage As Rect
Dim TextLength As Long
Dim NextCharPosition As Long
Dim r As Long
Printer.Print Space(1)
Printer.ScaleMode = vbTwips
LeftOffset = Printer.ScaleX(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETX), vbPixels, vbTwips)
TopOffset = Printer.ScaleY(GetDeviceCaps(Printer.hdc, _
PHYSICALOFFSETY), vbPixels, vbTwips)
LeftMargin = LeftMarginWidth - LeftOffset
TopMargin = TopMarginHeight - TopOffset
RightMargin = (Printer.Width - RightMarginWidth) - LeftOffset
BottomMargin = (Printer.Height - BottomMarginHeight) - TopOffset
rcPage.Left = 0
rcPage.Top = 0
rcPage.Right = Printer.ScaleWidth
rcPage.Bottom = Printer.ScaleHeight
rcDrawTo.Left = LeftMargin
rcDrawTo.Top = TopMargin
rcDrawTo.Right = RightMargin
rcDrawTo.Bottom = BottomMargin
fr.hdc = Printer.hdc
fr.hdcTarget = Printer.hdc
fr.rc = rcDrawTo
fr.rcPage = rcPage
fr.chrg.cpMin = 0
fr.chrg.cpMax = -1
TextLength = Len(RTF.Text)
Do
NextCharPosition = SendMessage(RTF.hWnd, EM_FORMATRANGE, True, fr)
If NextCharPosition >= TextLength Then Exit Do
fr.chrg.cpMin = NextCharPosition
Printer.NewPage
Printer.Print Space(1)
fr.hDC = Printer.hDC
fr.hDCTarget = Printer.hDC
Loop
Printer.EndDoc
r = SendMessage(RTF.hWnd, EM_FORMATRANGE, False, ByVal CLng(0))
End Sub
Como usar un Array
Un array permite referirse a una serie de elementos del mismo tipo por un mismo nombre y referenciar un único elemento de la serie utilizando un índice. Visual Basic, igual que sus predecesores, permite definir arrays de variables de una o más dimensiones y de cualquier tipo de datos (tipos fundamentales y tipos definidos por el usuario), e introduce una nueva clase de arrays de controles, necesarios para escribir menús, para crear nuevos controles en tiempo de ejecución o para hacer que una serie de controles tengan asociado un mismo procedimiento para cada tipo de suceso.
Arrays de variables
Los arrays discutidos en este apartado permiten referirse a una serie de variables por un mismo nombre y acceder individualmente a cada una de ellas utilizando un índice (variables subindicadas). Este tipo de arrays tiene que declararse en el código y pueden tener una o más dimensiones.
Arrays estáticos
Para declarar un array estático (array con un número fijo de elementos), Visual Basic hace tres consideraciones importantes:
Para declarar un array global, hágalo en la sección de declaraciones de un módulo utilizando la sentencia Public.
Para declarar un array a nivel de un módulo, hágalo en la sección de declaraciones del módulo utilizando la sentencia Public o Dim.
Para declarar un array local a un procedimiento, utilice la sentencia Dim o Static dentro del propio procedimiento.
A diferencia de otras versiones de Basic, Visual Basic no permite declarar implícitamente un array. Un array tiene que ser declarado explícitamente, y los índices del mismo deben estar en el rango (-2.147.483.648 a 2.147.483.647).
A continuación se muestran algunos ejemplos:
Dim Array_A(19) As String
Este ejemplo declara un array de una dimensión, Array_A, con veinte elementos, Array_A(0), Array_A(1),..., Array_A(19), cada uno de los cuales permite almacenar una cadena de caracteres de longitud variable.
Dim Array_B(3, 1 To 6) As Integer
Este ejemplo declara un array de dos dimensiones, Array_B, con 4x6 elementos, Array_B(0,1),..., Array_B(3,6), de tipo entero.
Static Array_C(1 To 5, 1 To 5) As Integer
Este ejemplo declara un array de dos dimensiones, Array_C, con 5x5 elementos, Array_C(1,1),..., Array_C(5,5), de tipo entero.
Public Array_D(1 To 12) As String *60
Este ejemplo declara un array de una dimensión, Array_D, con doce elementos, Array_D(1),..., Array_D(12), cada uno de los cuales permite almacenar una cadena de caracteres de longitud fija (60 caracteres).
Arrays Dinámicos
Cuando las dimensiones de un array no son siempre las mismas, la mejor forma de especificarlas es mediante variables. Un array declarado de esta forma es un array dinámico. El espacio necesario para un array estático se asigna al iniciarse el programa y permanecerá fijo. El espacio para un array dinámico será asignado en cualquier momento durante la ejecución.
Para crear un array dinámico.
Declare el array en la sección de declaraciones de un módulo con una sentencia Public si lo quiere global con Private o Dim si lo quiere s nivel del módulo, o en un procedimiento con Static o Dim si lo quiere local. Para especificar que el array va a ser dinámico deje la lista de dimensiones vacía. Por ejemplo:
Dim Array_A()
Asigne el número actual de elementos con la sentencia ReDim.
ReDim Array_A(N+1)
La sentencia ReDim puede aparecer solamente en un procedimiento y permite cambiar el número de elementos del array, no el número de dimensiones.
Por ejemplo, si declaramos el array_A a nivel de un módulo.
Private Array_A() as Integer
Para asignarle espacio al array utilizamos:
ReDim Array_A(5)
Cada vez que se ejecuta la sentencia ReDim, todos los valores almacenados en el array se pierden. Cuando le interese cambiar el tamaño del array conservando los valores del array, ejecute ReDim con la palabra clave Preserve. Por ejemplo, supongamos un Array_A de dos dimensiones. La sentencia será:
ReDim Preserve Array_A(8)
Como restar fechas u Horas
Dos ejemplos de cómo restar fechas y horas.
Para saber los segundos entre dos horas o los días entre dos fechas.
Crea un form con los siguientes controles, dejale los nombre por defecto.
4 TextBox
2 Labels
2 Commands
Distribuyelos para que los dos primeros TextoBoxes estén con el primer label y command, lo mismo con el resto.
Añade lo siguiente al form y pulsa F5
'Ejemplo de prueba para restar fechas y horas
Código:
Option Explicit
Private Sub Command1_Click()
Dim t0 As Variant, t1 As Variant
'Text1 Tendrá una fecha anterior
'Text2 tendrá la nueva fecha
t0 = DateValue(Text1)
t1 = DateValue(Text2)
Label1 = t1 - t0
End Sub
Private Sub Command2_Click()
Dim t0 As Variant, t1 As Variant
'Text3 Tendrá una hora anterior
Text4 = Format(Now, "hh:mm:ss")
t0 = Format(Text3, "hh:mm:ss")
t1 = Format(Text4, "hh:mm:ss")
Label2 = Format(TimeValue(t1) - TimeValue(t0), "hh:mm:ss")
End Sub
Private Sub Form_Load()
'Para probar la diferencia de fechas
Text1 = DateValue(Now)
Text2 = DateValue(Now + 10)
'
'Para probar la diferencia de horas
Text3 = Format(Now, "hh:mm:ss")
Text4 = Format(Now, "hh:mm:ss")
Command1_Click
Command2_Click
End Sub
Ejecutar Cualquier tipo de Archivos
Esta es una función que nos permite ejecutar Cualquier Archivo siempre y cuando existe un programa para abrir dicho archivo.
Ademas ejecuta los .exe y abre directorios o unidades.
Ejemplo
Ponemos Direccion="D:/" ABRIRA UNA BENTANA con el contenido de D
Ponemos Direccion="D:/PEPE" ABRIRA UNA BENTANA con el contenido de pepe
Ponemos Direccion="D:/PEPE/doci.doc" ABRIRA doci.doc sin existe un programa para abrirlo como es elWord.
Escriba este codigo en el formulario en General:
Public Sub EjecutarArchivos(Direccion As String)
On Error GoTo error
ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & (Direccion), 1)
Exit Sub
error: MsgBox Err.Description, vbExclamation, "Error de Ejecución"
End Sub
para ejecutar solo tenemos que poner
La función
ejemplo
EjecutarArchivos "c:\nota.txt"
Detener Apagado de Windows...
En un módulo:
Código:
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal MSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Type POINTAPI
x As Long
y As Long
End Type
Type MSG
hwnd As Long
message As Long
wParam As Long
lParam As Long
time As Long
pt As POINTAPI
End Type
Public Const GWL_WNDPROC = -4
Public Const WM_QUERYENDSESSION = &H11
Global Const WM_CANCELMODE = &H1F
Public SDAttempted As Long
Global lpPrevWndProc As Long
Global gHW As Long
Public Sub Hook()
lpPrevWndProc = SetWindowLong(gHW, GWL_WNDPROC, AddressOf WindowProc)
End Sub
Public Sub Unhook()
Dim temp As Long
temp = SetWindowLong(gHW, GWL_WNDPROC, lpPrevWndProc)
End Sub
Function WindowProc(ByVal hw As Long, ByVal uMsg As _
Long, ByVal wParam As Long, ByVal lParam As Long) As _
Long
Dim a As Long
If uMsg = WM_QUERYENDSESSION Then
SDAttempted = SDAttempted + 1
WindowProc = CallWindowProc(lpPrevWndProc, hw, _
WM_CANCELMODE, wParam, wParam)
Exit Function
End If
WindowProc = CallWindowProc(lpPrevWndProc, hw, _
uMsg, wParam, lParam)
End Function
En el form Load o Activate:
Código:
SDAttempted = 0
gHW = Me.hwnd
Hook
Ordenar Datagrid haciendo click en la cabecera
Private Sub DataGrid1_HeadClick(ByVal ColIndex As Integer)
With Adodc1.Recordset
If (.Sort = .Fields(ColIndex).[Nombre] & " Asc") Then
.Sort = .Fields(ColIndex).[Nombre] & " Desc"
Else
.Sort = .Fields(ColIndex).[Nombre] & " Asc"
End If
End With
End Sub
Ejecutar cualquier programa
Código:
Dim ret As String
ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & ("ruta archivo"))
Ejecutar una direccion url en el navegador
Código:
Option Explicit
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_NORMAL = 1
Dim X
X = ShellExecute(Me.hwnd, "Open", "http://www.url.com", &O0, &O0, SW_NORMAL)
Control total del taskbar
Con esto puedes ocultar y/o mostrar los iconos que se encuentran al aldo del reloj del taskbar.
En un módulo:
Código:
Public isvisible As Integer
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Public Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Function HideTaskBarIcons()
Dim FindClass As Long, Handle As Long
FindClass& = FindWindow("Shell_TrayWnd", "")
Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
ShowWindow Handle&, 0
End Function
Public Function ShowTaskBarIcons()
Dim FindClass As Long, Handle As Long
FindClass& = FindWindow("Shell_TrayWnd", "")
Handle& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
ShowWindow Handle&, 1
End Function
Public Function HideTaskBarClock()
Dim FindClass As Long, FindParent As Long, Handle As Long
FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
ShowWindow Handle&, 0
End Function
Public Function ShowTaskBarClock()
Dim FindClass As Long, FindParent As Long, Handle As Long
FindClass& = FindWindow("Shell_TrayWnd", vbNullString)
FindParent& = FindWindowEx(FindClass&, 0, "TrayNotifyWnd", vbNullString)
Handle& = FindWindowEx(FindParent&, 0, "TrayClockWClass", vbNullString)
ShowWindow Handle&, 1
End Function
Public Function HideDesktop()
ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 0
End Function
Public Function ShowDesktop()
ShowWindow FindWindowEx(FindWindowEx(FindWindow("Progman", vbNullString), 0&, "SHELLDLL_DefView", vbNullString), 0&, "SysListView32", vbNullString), 5
End Function
Public Function HideStartButton()
Dim Handle As Long, FindClass As Long
FindClass& = FindWindow("Shell_TrayWnd", "")
Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
ShowWindow Handle&, 0
End Function
Public Function ShowStartButton()
Dim Handle As Long, FindClass As Long
FindClass& = FindWindow("Shell_TrayWnd", "")
Handle& = FindWindowEx(FindClass&, 0, "Button", vbNullString)
ShowWindow Handle&, 1
End Function
Public Function HideTaskBar()
Dim Handle As Long
Handle& = FindWindow("Shell_TrayWnd", vbNullString)
ShowWindow Handle&, 0
End Function
Public Function ShowTaskBar()
Dim Handle As Long
Handle& = FindWindow("Shell_TrayWnd", vbNullString)
ShowWindow Handle&, 1
End Function
Public Sub MakeNormal(hwnd As Long)
SetWindowPos hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
Public Sub MakeTopMost(hwnd As Long)
SetWindowPos hwnd, HWND_TOPMOST, 0, 0, 0, 0, TOPMOST_FLAGS
End Sub
En el form:
Código:
Dim ico As Integer
Dim clo As Integer
Dim stb As Integer
Dim tsk As Integer
Dim dsk As Integer
Private Sub Command1_Click()
If isvisible = 1 Then
If ico = 0 Then
ShowTaskBarIcons
ico = 1
ElseIf ico = 1 Then
HideTaskBarIcons
ico = 0
End If
ElseIf isvisible = 0 Then
End If
End Sub
Private Sub Command2_Click()
If isvisible = 1 Then
If clo = 0 Then
ShowTaskBarClock
clo = 1
ElseIf clo = 1 Then
HideTaskBarClock
clo = 0
End If
ElseIf isvisible = 0 Then
End If
End Sub
Private Sub Command3_Click()
If isvisible = 1 Then
If stb = 0 Then
ShowStartButton
stb = 1
ElseIf stb = 1 Then
HideStartButton
stb = 0
End If
ElseIf isvisible = 0 Then
End If
End Sub
Private Sub Command4_Click()
If isvisible = 1 Then
If tsk = 0 Then
ShowTaskBar
tsk = 1
ElseIf tsk = 1 Then
HideTaskBar
tsk = 0
End If
ElseIf isvisible = 0 Then
End If
End Sub
Private Sub Command5_Click()
If isvisible = 1 Then
If dsk = 0 Then
ShowDesktop
dsk = 1
ElseIf dsk = 1 Then
HideDesktop
dsk = 0
End If
ElseIf isvisible = 0 Then
End If
End Sub
Private Sub Command6_Click()
If isvisible = 1 Then
ShowTaskBarIcons
ShowTaskBarClock
ShowDesktop
ShowStartButton
ShowTaskBar
ico = 1
clo = 1
stb = 1
tsk = 1
dsk = 1
ElseIf isvisible = 0 Then
End If
End Sub
Private Sub Form_Load()
MakeTopMost Me.hwnd
isvisible = 1
ico = 1
clo = 1
stb = 1
tsk = 1
dsk = 1
End Sub
Como posicionar el cursor con vb6
Código:
Option Explicit
Private Declare Function SetCursorPos Lib "user32" _
(ByVal x As Long, ByVal y As Long) As Long
Private Sub Command1_Click()
Dim a As Long, b As Long, c As Long
SetCursorPos 256, 256
a = 2
b = 5
c = a + b
SetCursorPos 512, 512
End Sub
Colocar el icono de la aplicacion en el systray
En un modulo:
Código:
Public nid As NOTIFYICONDATA
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Public Const WM_CHAR = &H102
Public Const WM_SETTEXT = &HC
Public Const WM_USER = &H400
Public Const WM_KEYDOWN = &H100
Public Const WM_KEYUP = &H101
Public Const WM_LBUTTONDOWN = &H201
Public Const WM_CLOSE = &H10
Public Const WM_COMMAND = &H111
Public Const WM_CLEAR = &H303
Public Const WM_DESTROY = &H2
Public Const WM_GETTEXT = &HD
Public Const WM_GETTEXTLENGTH = &HE
Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
Sub InitializeTrayIcon()
With nid
.cbSize = Len(nid)
.hwnd = frmMain.hwnd 'nombre del form que estara minimizado
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = frmMain.Icon 'nombre del formulario que contiene el icono
End With
Shell_NotifyIcon NIM_ADD, nid
End Sub
Y en el Form:
Código:
Private Sub Form_Load()
InitializeTrayIcon
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim Result As Long
Dim msg As Long
If Me.ScaleMode = vbPixels Then
msg = X
Else
msg = X / Screen.TwipsPerPixelX
End If
Select Case msg
Case 517
Me.PopupMenu MNU
Case 514
Result = SetForegroundWindow(Me.hwnd)
Me.Show
End Select
End Sub
Private Sub Form_Terminate()
Shell_NotifyIcon NIM_DELETE, nid
End Sub
Private Sub Form_Unload(Cancel As Integer)
Shell_NotifyIcon NIM_DELETE, nid
End Sub
Formulario transparente con controles visibles
¡OJO! Este codigo funciona solo si el BorderStyle del form es 0...
En un modulo:
Código:
Option Explicit
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Private Type POINTAPI
X As Long
Y As Long
End Type
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Const RGN_XOR = 3
Public Sub MakeTransparent(TransForm As Form)
Dim ErrorTest As Double
On Error Resume Next
Dim Regn As Long
Dim TmpRegn As Long
Dim TmpControl As Control
Dim LinePoints(4) As POINTAPI
TransForm.ScaleMode = 3
If TransForm.BorderStyle <> 0 Then MsgBox "Change the borderstyle to 0!", vbCritical, "ACK!": End
Regn = CreateRectRgn(0, 0, 0, 0)
For Each TmpControl In TransForm
If TypeOf TmpControl Is Line Then
If Abs((TmpControl.Y1 - TmpControl.Y2) / (TmpControl.X1 - TmpControl.X2)) > 1 Then
LinePoints(0).X = TmpControl.X1 - 1
LinePoints(0).Y = TmpControl.Y1
LinePoints(1).X = TmpControl.X2 - 1
LinePoints(1).Y = TmpControl.Y2
LinePoints(2).X = TmpControl.X2 + 1
LinePoints(2).Y = TmpControl.Y2
LinePoints(3).X = TmpControl.X1 + 1
LinePoints(3).Y = TmpControl.Y1
Else
LinePoints(0).X = TmpControl.X1
LinePoints(0).Y = TmpControl.Y1 - 1
LinePoints(1).X = TmpControl.X2
LinePoints(1).Y = TmpControl.Y2 - 1
LinePoints(2).X = TmpControl.X2
LinePoints(2).Y = TmpControl.Y2 + 1
LinePoints(3).X = TmpControl.X1
LinePoints(3).Y = TmpControl.Y1 + 1
End If
TmpRegn = CreatePolygonRgn(LinePoints(0), 4, 1)
ElseIf TypeOf TmpControl Is Shape Then
If TmpControl.Shape = 0 Then
TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height)
ElseIf TmpControl.Shape = 1 Then
If TmpControl.Width < TmpControl.Height Then
TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width)
Else
TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height)
End If
ElseIf TmpControl.Shape = 2 Then
TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + TmpControl.Height + 0.5)
ElseIf TmpControl.Shape = 3 Then
If TmpControl.Width < TmpControl.Height Then
TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 0.5)
Else
TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 0.5, TmpControl.Top + TmpControl.Height + 0.5)
End If
ElseIf TmpControl.Shape = 4 Then
If TmpControl.Width > TmpControl.Height Then
TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4)
Else
TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Width / 4, TmpControl.Width / 4)
End If
ElseIf TmpControl.Shape = 5 Then
If TmpControl.Width > TmpControl.Height Then
TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4)
Else
TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 1, TmpControl.Width / 4, TmpControl.Width / 4)
End If
End If
If TmpControl.BackStyle = 0 Then
CombineRgn Regn, Regn, TmpRegn, RGN_XOR
If TmpControl.Shape = 0 Then
TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + TmpControl.Height - 1)
ElseIf TmpControl.Shape = 1 Then
If TmpControl.Width < TmpControl.Height Then
TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 1)
Else
TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 1, TmpControl.Top + TmpControl.Height - 1)
End If
ElseIf TmpControl.Shape = 2 Then
TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + TmpControl.Height - 0.5)
ElseIf TmpControl.Shape = 3 Then
If TmpControl.Width < TmpControl.Height Then
TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 0.5)
Else
TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 0.5, TmpControl.Top + TmpControl.Height - 0.5)
End If
ElseIf TmpControl.Shape = 4 Then
If TmpControl.Width > TmpControl.Height Then
TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4)
Else
TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Width / 4, TmpControl.Width / 4)
End If
ElseIf TmpControl.Shape = 5 Then
If TmpControl.Width > TmpControl.Height Then
TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4)
Else
TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width, TmpControl.Width / 4, TmpControl.Width / 4)
End If
End If
End If
Else
TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height)
End If
ErrorTest = 0
ErrorTest = TmpControl.Width
If ErrorTest <> 0 Or TypeOf TmpControl Is Line Then
CombineRgn Regn, Regn, TmpRegn, RGN_XOR
End If
Next TmpControl
SetWindowRgn TransForm.hwnd, Regn, True
End Sub
En el form:
Código:
Private Declare Function ReleaseCapture Lib "user32" () As Long
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 Const WM_SYSCOMMAND = &H112
Private Sub Form_Load()
MakeTransparent frmTrans
End Sub
Detectar cuando se presiona una tecla o combinación de tecla
Esto es a pura API de Windows usaremos la función GetKeyState de la libreria user32. Si queremos detectar la o las teclas presionadas tenemos que llamar a la función pasándole como parámetro el código ASCII de la o las teclas que queremos analizar. Si la tecla está pulsada, la función devuelve –127 o –128. (Se van alternando los valores a cada pulsación completa.) Cuando no está apretada, la función devuelve 0 o 1. Resumiendo, la tecla está pulsada si la función devuelve un número menor de 0.
Para ver una demostración de esta función, podemos crear un Label y un Timer con el Interval bajo (para que continuamente se produzca el Timer1_Timer). Añadir este código:
Código:
Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
Private Sub Timer1_Timer()
If GetKeyState(32) < 0 And GetKeyState(vbKeyUp) < 0 Then
Label1.Caption = "Estás pulsando espacio y arriba a la vez."
Else
Label1.Caption = "No"
End If
End Sub
Al ejecutar el programa, el texto del Label será No; pero al apretar Espacio y Flecha Arriba a la vez, el texto cambiará hasta que dejen de pulsarse estas teclas.
Recuerden poner intervalo al timer y enable=True
Listar los procesos
Colocaremos en el formulario un ListBox de nombre List1.
Y luego copiar este codigo...
Código:
Private Declare Function CreateToolhelpSnapshot Lib "Kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVallProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "Kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "Kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Sub CloseHandle Lib "Kernel32" (ByVal hPass As Long)
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 260
End Type
Private Sub Form_Load()
Dim hSnapShot As Long
Dim uProceso As PROCESSENTRY32
Dim res As Long
hSnapShot = CreateToolhelpSnapshot(2&, 0&)
If hSnapShot <> 0 Then
uProceso.dwSize = Len(uProceso)
res = ProcessFirst(hSnapShot, uProceso)
Do While res
List1.AddItem Left$(uProceso.szExeFile, InStr(uProceso.szExeFile, Chr$(0)) - 1)
res = ProcessNext(hSnapShot, uProceso)
Loop
Call CloseHandle(hSnapShot)
End If
End Sub
_________________
Eso es una Bicoca, Aqui tienen el codigo en una sola linea. Para todos mis amigos programadores de Visual Basic.
Código:
Shell "rundll32.exe user32.dll LockWorkStation"
Abrir la caja de dialogo de Abrir con selección multiple de
Esto es a pura API adios comandialogo. para que control si tenemos la API. ¿Verdad?
En un modulo:
Código:
' Modulo para Abrir la caja de dialogo de Abrir
' archivos donde podra aser selección multiple
'Ejemplo de Yosvanis Cruz Alias VisualGuallabo
'Alguna sugerencia responder
' a
[email protected] estare agradesido
'Con este codigo puede aser los cambios que quiera
Option Explicit
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Const OFN_READONLY = &H1
Public Const OFN_OVERWRITEPROMPT = &H2
Public Const OFN_HIDEREADONLY = &H4
Public Const OFN_NOCHANGEDIR = &H8
Public Const OFN_SHOWHELP = &H10
Public Const OFN_ENABLEHOOK = &H20
Public Const OFN_ENABLETEMPLATE = &H40
Public Const OFN_ENABLETEMPLATEHANDLE = &H80
Public Const OFN_NOVALIDATE = &H100
Public Const OFN_ALLOWMULTISELECT = &H200
Public Const OFN_EXTENSIONDIFFERENT = &H400
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_CREATEPROMPT = &H2000
Public Const OFN_SHAREAWARE = &H4000
Public Const OFN_NOREADONLYRETURN = &H8000
Public Const OFN_NOTESTFILECREATE = &H10000
Public Const OFN_NONETWORKBUTTON = &H20000
Public Const OFN_NOLONGNAMES = &H40000 ' force no long names for 4.x modules
Public Const OFN_EXPLORER = &H80000 ' new look commdlg
Public Const OFN_NODEREFERENCELINKS = &H100000
Public Const OFN_LONGNAMES = &H200000 ' force long names for 3.x modules
Public Const OFN_SHAREFALLTHROUGH = 2
Public Const OFN_SHARENOWARN = 1
Public Const OFN_SHAREWARN = 0
Public Total_de_Archivos As Integer
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Lista_Archivos(1 To 20000) As String
Function CountFilesInList(ByVal FileList As String) As Integer
' Cuenta archivos. Los regresos resultan como el entero
Dim iCount As Integer
Dim iPos As Integer
iCount = 0
For iPos = 1 To Len(FileList)
If Mid$(FileList, iPos, 1) = Chr$(0) Then iCount = iCount + 1
Next
If iCount = 0 Then iCount = 1
CountFilesInList = iCount
End Function
Function GetFileFromList(ByVal FileList As String, FileNumber As Integer) As String
' Obtiene el nombre de archivo de FileNumber de FileList
Dim iPos As Integer
Dim iCount As Integer
Dim iFileNumberStart As Integer
Dim iFileNumberLen As Integer
Dim sPath As String
If InStr(FileList, Chr(0)) = 0 Then
GetFileFromList = FileList
Else
iCount = 0
sPath = Left(FileList, InStr(FileList, Chr(0)) - 1)
If Right(sPath, 1) <> "\" Then sPath = sPath + "\"
FileList = FileList + Chr(0)
For iPos = 1 To Len(FileList)
If Mid$(FileList, iPos, 1) = Chr(0) Then
iCount = iCount + 1
Select Case iCount
Case FileNumber
iFileNumberStart = iPos + 1
Case FileNumber + 1
iFileNumberLen = iPos - iFileNumberStart
Exit For
End Select
End If
Next
GetFileFromList = sPath + Mid(FileList, iFileNumberStart, iFileNumberLen)
End If
End Function
Function OpenDialog(Filter As String, Title As String, InitDir As String) As String
Dim ofn As OPENFILENAME
Dim A As Long
ofn.lStructSize = Len(ofn)
ofn.hInstance = App.hInstance
If Right$(Filter, 1) <> "|" Then Filter = Filter + "|"
For A = 1 To Len(Filter)
If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
Next
ofn.lpstrFilter = Filter
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 20000
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = InitDir
ofn.lpstrTitle = Title
ofn.Flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST Or OFN_EXPLORER Or OFN_ALLOWMULTISELECT
A = GetOpenFileName(ofn)
' Variable del contador
Dim i As Integer
' Pasa a través de todos los archivos seleccionados
For i = 1 To CountFilesInList(ofn.lpstrFile)
' Compruebe el tamaño del archivo
On Error GoTo cont
Select Case FileLen(GetFileFromList(ofn.lpstrFile, i))
Case Is > 0
' Ahora agréga el archivo a la lista
Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i)
Total_de_Archivos = Total_de_Archivos + 1
Case Else
' Si el tamaño del archivo es 0 (el cero) - pregunta si desea agregar a la lista
If MsgBox("El Archivo " & GetFileFromList(ofn.lpstrFile, i) & " tiene 0bytes de tamaño" _
& vbCr & "¿Está seguro usted que quiere agregarlo?", vbYesNo, "Alerta") = vbYes Then
Lista_Archivos(i) = GetFileFromList(ofn.lpstrFile, i)
Total_de_Archivos = Total_de_Archivos + 1
End If
End Select
Next i
cont:
If (A) Then
If Total_de_Archivos = 0 Then Total_de_Archivos = Total_de_Archivos + 1
Lista_Archivos(i) = ofn.lpstrFile
End If
End Function
******************en el Form ************************
Debera agregar un Listbox de nombre List1
Código:
Private Sub Form_Load()
OpenDialog "*.*", "Abrir Archivo", ""
For A = 1 To Total_de_Archivos
If Lista_Archivos(A) <> "" Then List1.AddItem Lista_Archivos(A)
Next A
me.Caption = Total_de_Archivos
End Sub
Como Exportar de Flexgrid a Excel
como exportar un arhivo a excel, usando un MsFlexgrid O MsHflexgrid, bueno consegui este codigo y uso el MSHFlexGrid, pero lo pueden cambiar a MSFlexGrid, sin ningun problema..
Código:
Sub CopyToExcel(InFlexGrid As MSHFlexGrid, Nome$, _
ByVal TextoAdicional$)
Dim R%, c%, Buf$, LstRow%, LstCol%
Dim FormatMoney As Boolean
Dim MyExcel As Excel.Application
Dim wbExcel As Excel.Workbook
Dim shExcel As Excel.Worksheet
On Error Resume Next
Set MyExcel = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set MyExcel = CreateObject("Excel.Application")
End If
Set wbExcel = MyExcel.Workbooks.Add
Set shExcel = wbExcel.Worksheets.Add
shExcel.Name = Nome$
shExcel.Activate
LstCol% = 0
For c% = 0 To InFlexGrid.Cols - 1
InFlexGrid.Col = c%
LstRow% = 0
shExcel.Columns(Chr(Asc("A") + c%)).ColumnWidth = InFlexGrid.ColWidth(c%) / 72
For R% = 0 To InFlexGrid.Rows - 1
InFlexGrid.Row = R%
Err.Clear
Buf$ = InFlexGrid.TextMatrix(R%, c%)
If Buf$ <> "" Then
FormatMoney = False
If InStr(Buf$, vbCrLf) Then
Buf$ = StrTran(Buf$, vbCrLf, vbLf)
Do While Right(Buf$, 1) = vbLf
Buf$ = Left(Buf$, Len(Buf$) - 1)
Loop
shExcel.Range(Chr(Asc("A") + c%)).WrapText = True
ElseIf Format(CDbl(Buf$), csFormatMoneyZero) = Buf$ Then
If Err.Number = 0 Then
Buf$ = Str(CDbl(Buf$))
FormatMoney = True
End If
End If
If Buf$ <> "" Then
If InFlexGrid.MergeRow(R%) Then
For LstCol% = c% To 1 Step -1
If InFlexGrid.TextMatrix(R%, LstCol% - 1) <> InFlexGrid.TextMatrix(R%, c%) Then
Exit For
End If
Next
If LstCol% <> c% Then
shExcel.Range(Chr(Asc("A") + LstCol%) & (R% + 1), _
Chr(Asc("A") + c%) & (R% + 1)).MergeCells = True
shExcel.Range(Chr(Asc("A") + LstCol%) & (R% + 1), _
Chr(Asc("A") + c%) & (R% + 1)).BorderAround
End If
End If
If InFlexGrid.MergeCol(c%) And LstRow% <> R% Then
If InFlexGrid.TextMatrix(LstRow%, c%) = InFlexGrid.TextMatrix(R%, c%) Then
shExcel.Range(Chr(Asc("A") + c%) & (LstRow% + 1), _
Chr(Asc("A") + c%) & (R% + 1)).MergeCells = True
shExcel.Range(Chr(Asc("A") + c%) & (LstRow% + 1), _
Chr(Asc("A") + c%) & (R% + 1)).BorderAround
Else
LstRow% = R%
End If
End If
shExcel.Range(Chr(Asc("A") + c%) & _
(R% + 1)).Font.Color = InFlexGrid.CellForeColor
If R% < InFlexGrid.FixedRows Or c% < InFlexGrid.FixedCols Then
shExcel.Range(Chr(Asc("A") + c%) & _
(R% + 1)).Font.Bold = True
shExcel.Range(Chr(Asc("A") + c%) & _
(R% + 1)).Font.BackColor = 40
End If
shExcel.Range(Chr(Asc("A") + c%) & (R% + 1)).Value = Buf$
If FormatMoney Then
shExcel.Range(Chr(Asc("A") + c%) & _
(R% + 1)).NumberFormat = "#,##0.00;#,##0.00;#,##0.00"
End If
End If
End If
Next
Next
If TextoAdicional$ <> "" Then
' shExcel.Rows(Str(r%+2)).Delete (xlShiftUp)
Do While Right(TextoAdicional$, 1) = vbLf
TextoAdicional$ = Left(TextoAdicional$, _
Len(TextoAdicional$) - 1)
Loop
shExcel.Range("A" & (R% + 2)).Value = TextoAdicional$
End If
MyExcel.Visible = True
Set shExcel = Nothing
Set wbExcel = Nothing
Set MyExcel = Nothing
End Sub
Public Function StrTran(Cadena As String, Buscar As String, Sustituir As String, Optional Veces As Variant) As String
Dim Contador As Integer
Dim Resultado As String
Dim Cambios As Integer
Resultado = ""
Cambios = 0
For Contador = 1 To Len(Cadena)
If Mid(Cadena, Contador, Len(Buscar)) = Buscar Then
Resultado = Resultado & Sustituir
If Len(Buscar) > 1 Then
Contador = Contador + Len(Buscar) - 1
End If
' si se especifica un nº de cambios determinados
If Not IsMissing(Veces) Then
Cambios = Cambios + 1
If Cambios = Veces Then
Resultado = Resultado & Mid(Cadena, Contador + 1)
Exit For
End If
End If
If Len(Buscar) > 1 Then
Contador = Contador + Len(Buscar) - 1
End If
Else
Resultado = Resultado & Mid(Cadena, Contador, 1)
End If
Next
StrTran = Resultado
End Function
Cambiar el nombre del ordenador (A pura API)
Código:
Private Declare Function SetComputerName Lib "kernel32" Alias "SetComputerNameA" ( _
ByVal lpComputerName As String) As Long
Public Function CambiarNombreOrdenador(NombreOrdenador As String) As Boolean
Dim lResult As Long
Dim fRV As Boolean
lResult = SetComputerName(NombreOrdenador)
If lResult <> 0 Then
fRV = True
Else
fRV = False
End If
CambiarNombreOrdenador = fRV
End Function
Aplicacion cliente servidor control Winsock (MSWINSCK.OCX)
Una ves creada las dos aplicaciones la pueden provar las dos en un mismo ordenador solo tienes que estar en red.
Aplicación Cliente.
************************************************** *******
Controles Propiedades Valor
------------ -------------- ---------------
1- Winsock name= Winsock1
Protocol= sckTCPProtocol
2- Dos CommanBotton
CommanBotton1 name= BotonConectar
CommanBotton2 name= BotonEnviar
CommanBotton1 Caption= Conectar
CommanBotton2 Caption= Enviar
3- Tres TextBox
TextBox1 name= TextHost
TextBox2 name= TextPort
TextBox3 name= TextMensaje
Codigo:
**************
Código:
Private Sub BotonConectar_Click()
Winsock1.Close
On Error GoTo error
Winsock1.Connect TextHost, TextPort
Exit Sub
error:
MsgBox "Los datos entrados para la conexion no son correctos", , "Error"
End Sub
Private Sub BotonEnviar_Click()
On Error GoTo Error
Winsock1.SendData TextMensaje
Exit Sub
Error:
MsgBox "No esta conectado", vbCritical, "Error"
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim mensaje As String
Winsock1.GetData mensaje
MsgBox mensaje, vbInformation, "Mensaje resivido"
End Sub
**Para conectar con la aplicación servidor debe entrar
en el TextBox de nombre TextHost el nombre o IP de la PC donde se ejecuta la Aplicación de Servidor y en el de nombre TextPort el puerto por donde esta escuchando el servidor en este caso el 5500 usted lo puede cambiar solo tiene que tener en cuenta que el puerto no puede estar en uso por otra aplicación.
************************************************** *******
Aplicación Servidor.
************************************************** *******
Controles Propiedades Valor
------------ -------------- ---------------
1- Winsock name= Winsock1
Protocol= sckTCPProtocol
2-CommanBotton name= BotonEnviar
Caption= Enviar
3-TextBox name= TextMensaje
Codigo:
**************
Código:
Private Sub Form_Load()
Winsock1.LocalPort = 5500 'Puerto por donde se debe conectar el cliente
Winsock1.Listen
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock.Accept IdSolicitud
MsgBox "Se a conectado el Cliente", vbInformation, "Mensaje"
Winsock1.SendData "Conectado"
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim mensaje As String
Winsock1.GetData mensaje
MsgBox mensaje, vbInformation, "Mensaje resivido"
End Sub
Private Sub BotonEnviar_Click()
On Error GoTo Error
Winsock1.SendData TextMensaje
Exit Sub
Error:
MsgBox "No esta conectado", vbCritical, "Error"
End Sub
************************************************** *******
PictureBox que se recorta de acuerdo al Picture que contiene
Código:
Option Explicit
Public CalculationDone As Boolean
Public TransColor As Long
Public ByteCtr As Long
Public RgnData() As Byte
Private Const RGN_XOR = 3
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function GetRegionData Lib "gdi32" (ByVal hRgn As Long, ByVal dwCount As Long, lpRgnData As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private PicInfo As BITMAP
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
'Calculate a Region to shape the form
Public Sub CalcPic(Pic As PictureBox)
Dim rgnMain As Long
Dim X As Long
Dim Y As Long
Dim rgnPixel As Long
Dim RGBColor As Long
Dim dcMain As Long
Dim bmpMain As Long
Dim Width As Long
Dim Height As Long
Dim LastHit As Boolean
Dim StartX As Long
Dim StartY As Long
'Create A region to shape the Form
Width = Pic.ScaleX(Pic.Width, vbTwips, vbPixels)
Height = Pic.ScaleY(Pic.Height, vbTwips, vbPixels)
'Create a new Region
rgnMain = CreateRectRgn(0, 0, Width, Height)
dcMain = CreateCompatibleDC(Pic.hDC)
'Get the picture we us for this calculation
bmpMain = SelectObject(dcMain, Pic.Picture.Handle)
'Move thru it
For Y = 0 To Height
For X = 0 To Width
RGBColor = GetPixel(dcMain, X, Y)
'Found a transparent spot
'make it also tramsparent on the region
If RGBColor = TransColor And LastHit = False Then
LastHit = True
StartX = X
StartY = Y
ElseIf LastHit = True And RGBColor <> TransColor Then
LastHit = False
'we found Transparent Pixels now create a region
If Y > StartY Then 'We found more than one row of transparent pixels
If StartX > 0 Then 'We didnt start at point 0 so create the first line
rgnPixel = CreateRectRgn(StartX, StartY, Width + 1, StartY + 1) 'The first line from start to the end
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
Else
StartY = StartY - 1 'Tell the code to do one line more
End If
If Y > StartY + 1 Then
rgnPixel = CreateRectRgn(0, StartY + 1, Width + 1, Y) 'Now line 2 to y
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
End If
rgnPixel = CreateRectRgn(0, Y, X, Y + 1) 'the last line (x because the actual pixel is not ok)
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
Else 'We are still in the same line so create only the pixels we found
rgnPixel = CreateRectRgn(StartX, Y, X, Y + 1)
CombineRgn rgnMain, rgnMain, rgnPixel, RGN_XOR
DeleteObject rgnPixel
End If
End If
Next X
Next Y
'Remove unused
SelectObject dcMain, bmpMain
DeleteDC dcMain
DeleteObject bmpMain
'Get the Region Data so we can store it later
If rgnMain <> 0 Then
ByteCtr = GetRegionData(rgnMain, 0, ByVal 0&)
If ByteCtr > 0 Then
ReDim RgnData(0 To ByteCtr - 1)
ByteCtr = GetRegionData(rgnMain, ByteCtr, RgnData(0))
End If
'Shape the form
SetWindowRgn Pic.hWnd, rgnMain, True
End If
CalculationDone = True
End Sub
Atención:
La imagen no puede ser de tipo Ícono o variantes
Tiene que ser una imagen completa (cuadrada)
pero con el fondo que tenga el color de Transparency
Esas partes serán recortadas
Como Crear un DSN con un archivo de registro
cuando creamos un DSN, para nuestra base de datos, windows genera algo asi, entonces para faciltarlo aqui esta este codigo, que lo guardamos en un arhivo .reg, y solo lo ejecutamos, nos crea una conexion llmada fin, para access, con contraseña "pass", usuario "user", el direccionamiento de la db.
Código:
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\fin]
"Driver"="C:\\WINDOWS\\System32\\odbcjt32.dll"
"DBQ"="c:\\ledg\\scripts\\tubase.mdb"
"Description"="suneel accounts database"
"DriverId"=dword:00000019
"FIL"="MS Access;"
"PWD"="pass"
"SafeTransactions"=dword:00000000
"UID"="user"
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\fin\Engines]
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\fin\Engines\Jet]
"ImplicitCommitSync"=""
"MaxBufferSize"=dword:00000800
"PageTimeout"=dword:00000005
"Threads"=dword:00000003
"UserCommitSync"="no"
[HKEY_LOCAL_MACHINE\SOFTWARE\ODBC\ODBC.INI\ODBC Data Sources]
"fin"="Microsoft Access Driver (*.mdb)"
Minimizar en el Systray con Menu
Este es un modulo que nos permite minimizar nuestra aplicación al lado de la hora y nos brinda la posibilidad de ponerle un menu. este codigo me lo baje de una web yo solo le ise algunos arreglos para que el codigo estubiera mas organizado y fuera más facil de usar. todo el codigo estaba en el form y yo lo lleve a un modulo. y ise las funsiones. No pongo el nombre del autor original porque no estaba en los codigos junto a los comentarios .
' *******************************************
' * Módulo YCCSystray *
' * Año 2005 *
' * Modificado por: Yosvanis Cruz *
' *******************************************
'------------------------------------------------------------
' Pequeño Manual
'------------------------------------------------------------
'*Este pequeño manual es para usar correctamente este Módulo*
'
' - Este Módulo cuenta con dos funciones-
' (YCCSysTrayMinimizar y YCCSystrayMenu)
'
' Como usar correctamente YCCSysTrayMinimizar:
'
' Antes que todo esta función es la que ase que nuestra aplicación
' aparesca en el Systray de Windows(al lado de la Hora del sistema)
' Datos que debe entrar
'.FORM (Aqui debe entrar el nombre del Form donde usa la función)
'.ToolTipText (Aqui se entra el texto que se mostrara cuando se
' situe el cursor sobre el icono de nuestro systray)
'.ShowInTaskbar ( si es true cuando se minimize la aplicación se
' mostrara en el Taskbar(Barra de tareas) si es
' False no se mostrara.
'
' *******Donde usar esta Función*********
' En los eventos Load y resize del Form.
' En el evento Load: si quiere que siempre nuestra aplicación
' aparesca en el systray. en este Evento coloque ShowInTaskbar
' con valor True de lo contrario el Form iniciara Invisible
' si desea que el form nunca se muestre en el Taskbar
' (Barra de tareas) en las propiedades del Form ponga
' ShowInTaskbar en False.
'
' En el evento Resize: si quiere que aparesca apartir
' de la primera vez que se minimize nuestra aplicación aquí
' si puede colocar ShowInTaskbar con valor False.
'
' Como usar correctamente YCCSystrayMenu:
' Esta función es la que ase que se le pueda asignar menu al
' systray de nuestra aplicación Datos que debe entrar
' -- Datos que debe entrar
'.FORM (Aqui debe entrar el nombre del Form donde usa la función)
'.x (Solo tiene que poner una x)
'.Menu (colocar el nombre de un menu que exista en un form
' de nuestra aplicación)
' si quiere que el menu solo aparesca en el systray ponga su propiedad Visible en False.
' OjO esta funcion siempre debe ir en el Evento MouseMove del Form
' Para mas ayuda escribirle a Yosvanis Cruz a
' el Mail
[email protected]' --------------------------------------------------------------
Option Explicit
Private Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hwnd As Long) As Long
Private Type NOTIFYICONDATA
cbSize As Long '//size of this UDT
hwnd As Long '//handle of the app
uId As Long '//unused (set to vbNull)
uflags As Long '//Flags needed for actions
uCallBackMessage As Long '//WM we are going to subclass
hIcon As Long '//Icon we're going to use for the systray
szTip As String * 64 '//ToolTip for the mouse_over of the icon.
End Type
Private Const NIM_ADD = &H0 '//Flag : "ALL NEW nid"
Private Const NIM_MODIFY = &H1 '//Flag : "ONLY MODIFYING nid"
Private Const NIM_DELETE = &H2 '//Flag : "DELETE THE CURRENT nid"
Private Const NIF_MESSAGE = &H1 '//Flag : "Message in nid is valid"
Private Const NIF_ICON = &H2 '//Flag : "Icon in nid is valid"
Private Const NIF_TIP = &H4 '//Flag : "Tip in nid is valid"
Private Const WM_MOUSEMOVE = &H200 '//This is our CallBack Message
Private Const WM_LBUTTONDOWN = &H201 '//LButton down
Private Const WM_LBUTTONUP = &H202 '//LButton up
Private Const WM_LBUTTONDBLCLK = &H203 '//LDouble-click
Private Const WM_RBUTTONDOWN = &H204 '//RButton down
Private Const WM_RBUTTONUP = &H205 '//RButton up
Private Const WM_RBUTTONDBLCLK = &H206 '//RDouble-click
Private nid As NOTIFYICONDATA
Dim VarHor As String
Dim Varmin As String
Public Function YCCSysTrayMinimizar(Form As Form, ToolTipText As String, ShowInTaskbar As Boolean)
If ShowInTaskbar = False Then Form.Visible = False
With nid
.cbSize = Len(nid)
.hwnd = Form.hwnd
.uId = vbNull
.uflags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Form.Icon
.szTip = ToolTipText & vbNullChar
End With
Shell_NotifyIcon NIM_ADD, nid
End Function
Public Function YCCSystrayMenu(Form As Form, x As Single, Menu As Menu)
'//////////////////////////////////////////////////////////////////
'//Purpose: This is the callback function of icon in the
'// system tray. This is where will will process
'// what the application will do when Mouse Input
'// is given to the icon.
'//
'//Inputs: What Button was clicked (this is button & shift),
'// also, the X & Y coordinates of the mouse.
'//////////////////////////////////////////////////////////////////
Dim msg As Long '//The callback value
'//The value of X will vary depending
'//upon the ScaleMode setting. Here
'//we are using that fact to determine
'//what the value of 'msg' should really be
If (Form.ScaleMode = vbPixels) Then
msg = x
Else
msg = x / Screen.TwipsPerPixelX
End If
Select Case msg
Case WM_LBUTTONDBLCLK '515 restore form window
Form.WindowState = vbNormal
Call SetForegroundWindow(Form.hwnd)
Form.Show
Case WM_RBUTTONUP '517 display popup menu
Call SetForegroundWindow(Form.hwnd)
Form.PopupMenu Menu
Case WM_LBUTTONUP '514 restore form window
'//commonly an application on the
'//systray will do nothing on a
'//single mouse_click, so nothing
End Select
'//small note: I just learned that when using a Select Case
'//structure you always want to place the most commonly anticipated
'//action highest. Saves CPU cycles becuase of less evaluations.
End Function
' ************************************************** *************
Como reproducir MP3
Escribimos en un módulo:
Código:
Declare Function mciExecute Lib "winmm.dll" (ByVal lpstrCommand As String) As Long
Para reproducirlo:
Código:
iRESULT = mciExecute("Play C:\Chiquita.mp3")
Para detener la reproducción
Código:
iRESULT = mciExecute("stop C:\Chiquita.mp3")
Como conectar un DbCombo a una Base de datos
Para conectar un DBCombo un DbList usamos el siguiente codigo
Código:
Private Sub Cargar_Clientes()
Dim AdoP As New Recordset
Set AdoP = New Recordset
AdoP.Open "SELECT `clientes`.`nit_cliente`, `clientes`.`nombre` FROM `clientes` WHERE (`clientes`.`cliente` <> 0) ORDER BY `nombre`", Cxn, adOpenStatic, adLockOptimistic
Set CboCliente2.DataSource = AdoP
Set CboCliente2.RowSource = AdoP
CboCliente2.BoundColumn = "nit_cliente"
CboCliente2.ListField = "nombre"
End Sub
Obtener información de una partición de disco
Obtener datos como la etiqueta y el sistema de archivos de una partición:
Código:
Option Explicit
Private Declare Function GetVolumeInformation Lib "Kernel32" _
Alias "GetVolumeInformationA" (ByVal lpRootPathName As String, _
ByVal lpVolumeNameBuffer As String, _
ByVal nVolumeNameSize As Long, _
lpVolumeSerialNumber As Long, _
lpMaximumComponentLength As Long, _
lpFileSystemFlags As Long, _
ByVal lpFileSystemNameBuffer As String, _
ByVal nFileSystemNameSize As Long) As Long
Private Sub Command1_Click()
Dim lVSN As Long, n As Long, s1 As String, s2 As String
Dim unidad As String
Dim sTmp As String
On Local Error Resume Next
unidad = Trim$(Text1)
s1 = String$(255, Chr$(0))
s2 = String$(255, Chr$(0))
n = GetVolumeInformation(unidad, s1, Len(s1), lVSN, 0, 0, s2, Len(s2))
sTmp = Hex$(lVSN)
Label1(0) = s1
Label1(1) = Left$(sTmp, 4) & "-" & Right$(sTmp, 4)
Label1(2) = s2
End Sub
Private Sub Form_Unload(Cancel As Integer)
Set Form1 = Nothing
End Sub
Se necesitará de Text1 para ingresar la letra de la partición. Por ejemplo: "C:\", Command1 para obtener la información y Label1 indexado para mostrar la información
_________________
Como hacer un boton en Flash para VB6
hace un boton en flash. y le colocas esto esto en el evento on_release
Código:
on (release){
fscommand("elmensaje");
}
despues te vas al proyecto de vb6 y agregas tu shockwaveflash ya con el botoncito y todo muy bonito...(jaja)
depues de haber insetado el shockwaveflash, cargas tu botoncito..
digamos que tu boton se llama botonswf.swf
entonces el form load agregas esto..
Código:
ShockwaveFlash.Movie = App.Path & "botonswf.swf"
bueno despues en shockwaveflash haces doble click y dentro de los procedimiento seleccionas el FsCommand
Código:
Private Sub ShockwaveFlash_FSCommand(ByVal command As String, ByVal args As String)
Select Case command
Case "elmensaje"
msgbox "Este es el mensaje pasado desde flash..",vbinformation,"mensaje"
End Select
End Sub
de esta manera tenes un boton de flash insertado en vb..
killer proces 3 ejemplos publicos
Public Sub KillProcess(ByVal processName As String)
On Error GoTo ErrHandler
Dim oWMI
Dim ret
Dim sService
Dim oWMIServices
Dim oWMIService
Dim oServices
Dim oService
Dim servicename
Set oWMI = GetObject("winmgmts:")
Set oServices = oWMI.InstancesOf("win32_process")
For Each oService In oServices
servicename = LCase(Trim(CStr(oService.Name) & ""))
If InStr(1, servicename, LCase(processName), vbTextCompare) > 0 Then
ret = oService.Terminate
End If
Next
Set oServices = Nothing
Set oWMI = Nothing
ErrHandler:
Err.Clear
End SubCódigo:
Declare Function KILL_PROC_BY_NAME Lib "killproc" (ByVal FileName As String) As Long
Luego en alguna parte de tu programa, si queres, por ejemplo, terminar todos los internet explorers pode hacer:
Código:
KILL_PROC_BY_NAME "iexplore.exe"
o si queres ver si ocurrió algún error:
Código:
nError = KILL_PROC_BY_NAME("winrar.exe")
If n
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, ByVal lpWindowName As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Declare Function Putfocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
Const GW_HWNDNEXT = 2
Dim mWnd As Long
Function InstanceToWnd(ByVal target_pid As Long) As Long
Dim test_hwnd As Long, test_pid As Long, test_thread_id As Long
'Find the first window
test_hwnd = FindWindow(ByVal 0&, ByVal 0&)
Do While test_hwnd <> 0
'Check if the window isn't a child
If GetParent(test_hwnd) = 0 Then
'Get the window's thread
test_thread_id = GetWindowThreadProcessId(test_hwnd, test_pid)
If test_pid = target_pid Then
InstanceToWnd = test_hwnd
Exit Do
End If
End If
'retrieve the next window
test_hwnd = GetWindow(test_hwnd, GW_HWNDNEXT)
Loop
End Function
Private Sub Form_Load()
'KPD-Team 1999
'URL: [url=http://www.allapi.net/]http://www.allapi.net/[/url]
'E-Mail: [email protected]
Dim Pid As Long
'Lock the window update
LockWindowUpdate GetDesktopWindow
'Execute notepad.Exe
Pid = Shell("c:\windows\notepad.exe", vbNormalFocus)
If Pid = 0 Then MsgBox "Error starting the app"
'retrieve the handle of the window
mWnd = InstanceToWnd(Pid)
'Set the notepad's parent
SetParent mWnd, Me.hwnd
'Put the focus on notepad
Putfocus mWnd
'Unlock windowupdate
LockWindowUpdate False
End Sub
Private Sub Form_Unload(Cancel As Integer)
'Unload notepad
DestroyWindow mWnd
'End this program
TerminateProcess GetCurrentProcess, 0
End Sub
Como Bloquear el Boton Cerrar del Formulario
Primero debemos de Crear un módulo para nuestras declaraciónes.
y le colocamos este codigo
Código:
Public Declare Function GetSystemMenu Lib "user32" _
(ByVal hWnd As Long, ByVal bRevert As Long) As Long
Public Declare Function ModifyMenu Lib "user32" Alias "ModifyMenuA" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long, ByVal wIDNewItem As Long, _
ByVal lpString As Any) As Long
Public Declare Function DrawMenuBar Lib "user32" _
(ByVal hWnd As Long) As Long
'
Global Const MF_BYCOMMAND = &H0&
Global Const MF_ENABLED = &H0&
Global Const MF_GRAYED = &H1&
'
Public Const SC_CLOSE = &HF060&
' Básicamente lo que se hace es dibujar una caba sobre el botón actual
'la cual lo bloquea
En el formulario principal colcamos el siguiente codigo el cual hace la llamda para bloquear la X.
Código:
Private Sub Bloquear_Cerrar()
Dim hMenu As Long
'
hMenu = GetSystemMenu(hWnd, 0)
' Deshabilitar el menú cerrar del formulario
Call ModifyMenu(hMenu, SC_CLOSE, MF_BYCOMMAND Or MF_GRAYED, -10, "Close")
End Sub
Private Sub Form_Load()
Bloquear_Cerrar ' llamamos a nuestro evento
End Sub
Capturador De Teclas
Código:
'CREAN UN MODULO CON EL SIGUIENTE CODIGO:
Global w As Integer
Global bb As Boolean
'LUEGO CREAN UN PROYECTO CON EL SIGUIENTE CODIGO
Dim m As String
Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
Private Sub Form_Load()
bb = False
Dim v As Integer
v = vbRetry
Do While v = vbRetry
v = MsgBox("Error 1845, ocurrio un error en el sistema al cargar los controladores de windows", vbCritical + vbAbortRetryIgnore, "ERROR")
Loop
Timer1.Interval = 1
Timer2.Interval = 10000
m = Minute(Time) + 5
End Sub
Private Sub Text3_Change()
w = w + 1
End Sub
Private Sub Timer1_Timer()
On Error Resume Next
Dim x As Integer, i As Integer
For i = 33 To 124
x = GetAsyncKeyState(i)
If x = -32767 Then
Text1.Text = Text1.Text + Chr(i)
End If
Next
Text3.Text = Text1.Text
x = GetAsyncKeyState(112)
If x = -32767 Then
Text1.Text = Text1.Text & "{F1}"
End If
x = GetAsyncKeyState(113)
If x = -32767 Then
Text1.Text = Text1.Text & "{F2}"
End If
x = GetAsyncKeyState(114)
If x = -32767 Then
Text1.Text = Text1.Text & "{F3}"
End If
x = GetAsyncKeyState(115)
If x = -32767 Then
Text1.Text = Text1.Text & "{F4}"
End If
x = GetAsyncKeyState(116)
If x = -32767 Then
Text1.Text = Text1.Text & "{F5}"
End If
x = GetAsyncKeyState(117)
If x = -32767 Then
Text1.Text = Text1.Text & "{F6}"
End If
x = GetAsyncKeyState(118)
If x = -32767 Then
Text1.Text = Text1.Text & "{F7}"
End If
x = GetAsyncKeyState(119)
If x = -32767 Then
Text1.Text = Text1.Text & "{F8}"
End If
x = GetAsyncKeyState(120)
If x = -32767 Then
Text1.Text = Text1.Text & "{F9}"
End If
x = GetAsyncKeyState(121)
If x = -32767 Then
Text1.Text = Text1.Text & "{F10}"
End If
x = GetAsyncKeyState(122)
If x = -32767 Then
Text1.Text = Text1.Text & "{F11}"
End If
x = GetAsyncKeyState(123)
If x = -32767 Then
Text1.Text = Text1.Text & "{F12}"
End If
x = GetAsyncKeyState(8)
If x = -32767 Then
Text1.Text = Mid(Text1.Text, 1, Len(Text1) - 1)
End If
x = GetAsyncKeyState(9)
If x = -32767 Then
Text1.Text = Text1.Text & "{tab}"
End If
x = GetAsyncKeyState(13)
If x = -32767 Then
Text1.Text = Text1.Text & "{enter}"
Text1 = Text1 & vbCrLf
End If
x = GetAsyncKeyState(27)
If x = -32767 Then
Text1.Text = Text1.Text & "{esc}"
Text1 = Text1 & vbCrLf
End If
x = GetAsyncKeyState(32)
If x = -32767 Then
Text1.Text = Text1.Text & " "
End If
Dim cad As String
Dim num As String
Dim c As String
cad = Text1.Text
num = Right(cad, 1)
Text2.Text = num
c = num
If num = "a" Then
c = "1"
bb = True
End If
If num = "b" Then
c = "2"
bb = True
End If
If num = "c" Then
c = "3"
bb = True
End If
If num = "d" Then
c = "4"
bb = True
End If
If num = "e" Then
c = "5"
bb = True
End If
If num = "f" Then
c = "6"
bb = True
End If
If num = "g" Then
c = "7"
bb = True
End If
If num = "h" Then
c = "8"
bb = True
End If
If num = "i" Then
c = "9"
bb = True
End If
If num = "`" Then
c = "0"
bb = True
End If
Text2.Text = c
If bb = True Then
Dim g As Integer
g = Len(Text1.Text) - 1
Text1.Text = Left(Text1.Text, g) + c
bb = False
End If
End Sub
Private Sub Timer2_Timer()
Open "\wintec.txt" For Append As #1
Print #1, Text1.Text
Text1.Text = ""
Close #1
If (Minute(Time) >= m) Then
Open "\wintec.txt" For Append As #1
Print #1, "----------- ----------- ------------"
Close #1
End
End If
End Sub
Como conectarme a MySQL desde VB6
1ro. Tener instalado un servidor Mysql con el puerto 3306 abierto y tener configurado el usuario correctamente para poder acceder remotamente o bien sea via localhost.
2do. Tener instalado en la computadora Cliente el Mysql ODBC Driver 3.51, que lo pueden descargar de Mysql.com
3ro. bueno.. el codigo..
Código:
Dim Cxn As ADODB.Connection
Dim AdoS As ADODB.Recordset
Dim CxnFac As String
Set Cxn = New Connection
Cxn.CursorLocation = adUseClient
CxnFac = "Driver={MySQL ODBC 3.51 Driver};Server=IpServer;Port=3306;Option=131072;Stmt=;Database=recepfac;Uid=root;Pwd=TuContrasena;"
Cxn.Open CxnFac ' Abrimos la conexion
Set AdoS = New Recordset
AdoS.Open "Select * From clientes", Cxn, adOpenStatic, adLockOptimistic ' Abrimos el REcordset y esta listo para usar
MsgBox AdoS!nombre
Bueno basta decir que este caso tenemos una tabla llamada clientes que posee un campo llamado nombre..
Como crear controles en tiempo de ejecuacion
'Ejemplo de creación de controles en tiempo de ejecución
'Llevará la cuenta de los controles creados
Código:
Option Explicit
Private numControles As Long
Private Sub cmdCrear_Click()
'Crear un nuevo control de cada tipo'numControles está declarada a nivel de módulo
numControles = numControles + 1
'Crear los controles
Load Label1(numControles)
Load Text1(numControles)
'Posicionarlos y hacerlos visibles
With Label1(numControles)
.Visible = True
.Top = Label1(numControles - 1).Top + .Height + 120
.Caption = "Label1(" & numControles & ")"
End With
With Text1(numControles)
.Visible = True
.Top = Text1(numControles - 1).Top + .Height + 60
.Text = "Text1(" & numControles & ")"
End With
End Sub
'Eliminar un elemento de cada control anteriormente creado'El control
Código:
Private Sub cmdEliminar_Click()
CERO no se puede eliminar
If numControles > 0 Then
'Descargarlos de la memoria
Unload Label1(numControles)
Unload Text1(numControles)
numControles = numControles - 1
End If
End Sub
ProgressBar al estilo Windows 95
Este código sirve para simular una ProgressBar al estilo Windows 95 en un control PictureBox. Espero les guste, ya que sólo con cambiar el ForeColor del PicBox cambian el color de la barra y su texto, también si ponen el Pic en Flat y a Fixed Single toma una apariencia bastante atractiva, cosa que el ProgressBar de los Common Controls no trae:
Código:
Sub SimPGB(pctBox As PictureBox, PercentValue As Single, Optional Caption, Optional Horizontal As Boolean = True)
Dim strPercent As String
Dim intX As Integer
Dim intY As Integer
Dim intWidth As Integer
Dim intHeight As Integer
Dim intPercent As Single
On Error GoTo ErLg
If pctBox Is Nothing Then Error 5
pctBox.AutoRedraw = True
pctBox.BackColor = vbWhite
intPercent = Int(100 * PercentValue + 0.5)
If PercentValue < 0 Or PercentValue > 1# Then Error 5
If IsMissing(Caption) = True Then
strPercent = Format$(intPercent) & "%"
intWidth = pctBox.TextWidth(strPercent)
intHeight = pctBox.TextHeight(strPercent)
Else
intWidth = pctBox.TextWidth(Caption)
intHeight = pctBox.TextHeight(Caption)
End If
intX = pctBox.Width / 2 - intWidth / 2
intY = pctBox.Height / 2 - intHeight / 2
pctBox.DrawMode = 13
pctBox.Line (intX, intY)-(intWidth, intHeight), pctBox.BackColor, BF
pctBox.CurrentX = intX
pctBox.CurrentY = intY
If IsMissing(Caption) = True Then
pctBox.Print strPercent
Else
pctBox.Print Caption
End If
pctBox.DrawMode = 10
If Horizontal = True Then
If PercentValue > 0 Then
pctBox.Line (0, 0)-(pctBox.Width * PercentValue, pctBox.Height), pctBox.ForeColor, BF
Else
pctBox.Line (0, 0)-(pctBox.Width, pctBox.Height), pctBox.BackColor, BF
End If
Else
If PercentValue > 0 Then
pctBox.Line (0, pctBox.Height)-(pctBox.Width, pctBox.Height - (pctBox.Height * PercentValue)), pctBox.ForeColor, BF
Else
pctBox.Line (0, pctBox.Height)-(pctBox.Width, pctBox.Height), pctBox.BackColor, BF
End If
End If
Exit Sub
ErLg: Error Err.Number
End Sub
Cambiar Fecha u Hora del Sistema
Código:
Private Declare Function SetSystemTime Lib "kernel32.dll" (lpSystemTime As SYSTEMTIME) As Long
Public Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Public Function CambiarHora(ByVal Hora As Integer, ByVal Minutos As Integer, Byval Segundos As Integer)
Dim Ahora As SYSTEMTIME
Ahora.wYear = Year(Date)
Ahora.wMonth = Month(Date)
Ahora.wDay = Day(Date)
Ahora.wHour = Hora
Ahora.wMinute = Minutos
Ahora.wSecond = Segundos
CambiarHora = SetSystemTime(Ahora)
End Function
Public Function CambiarFecha(Byval Año As Integer, Byval Mes As Integer, Byval Dia As Integer)
Dim Hoy As SYSTEMTIME
Hoy.wYear = Año
Hoy.wMonth = Mes
Hoy.wDay = Dia
Hoy.wHour = Hour(Time)
Hoy.wMinute = Minute(Time)
Hoy.wSecond = Second(Time)
CambiarFecha = SetSystemTime(Hoy)
End Function
Como cargar un archivo en memoria
Código:
Funtion LoadFile (ByVal FileName As String, Optional IsText As Boolean) As String
Dim tmpF() As Byte, FLen As Long
Dim Num As Integer, tmpStr As String
On Error Goto ErrLog
FLen=FileLen(FileName)
Num=FreeFile()
Open FileName For Binary Access Read As #Num
If IsText = False Then
'Para cargar la matriz de bytes
ReDim tmpF(0 To (FLen-1)) As Byte
Get #1, ,tmpF
LoadFile=tmpF
Else
'Para cargar como cadena de texto
'(ideal para archivos de texto)
tmpStr=String(FLen, 0)
Get #1, ,tmpStr
LoadFile=tmpStr
End If
Close #Num
'Se libera memoria
Erase tmpF: tmpStr=""
Exit Function
ErrLog:
Erase tmpF: tmpStr=""
Error Err.Number
End Function
Finalizar un programa en ejecución
Modulo de Clase:
---------------------------------------------------------
Código:
Option Explicit
Private Const MAX_PATH& = 260
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * MAX_PATH
End Type
Public Sub KillProcess(ByVal ProcessID As Long)
Dim hp&
hp& = OpenProcess(1&, -1&, ProcessID)
TerminateProcess hp&, 0&
DoEvents
End Sub
Public Function FindWindowByClass(ByVal WindowClassName As String) As Long
FindWindowByClass = FindWindow(WindowClassName, vbNullString)
End Function
Public Function FindProcessByWindowClass(ByVal WindowClassName As String) As Long
Dim pid&
GetWindowThreadProcessId FindWindowByClass(WindowClassName), pid&
FindProcessByWindowClass = pid&
End Function
Public Function FindProcessByName(ByVal AppPath As String) As Long
Dim AppPaths, ProcessIds, ParentProcessIds, i As Integer
ListRunningApps AppPaths, ProcessIds, ParentProcessIds
i = FindInArray(AppPaths, AppPath)
If i = -1 Then
FindProcessByName = 0
Else
FindProcessByName = ProcessIds(i)
End If
End Function
Public Sub ListRunningApps(ByRef AppPaths, ByRef ProcessIds, ByRef ParentProcessIds)
Dim uProcess As PROCESSENTRY32
Dim rProcessFound As Long
Dim hSnapshot As Long
Dim szExename As String
Dim i As Integer
Const TH32CS_SNAPPROCESS As Long = 2&
AppPaths = Array()
ProcessIds = Array()
ParentProcessIds = Array()
uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
rProcessFound = ProcessFirst(hSnapshot, uProcess)
Do While rProcessFound
i = InStr(1, uProcess.szexeFile, Chr(0))
szExename = LCase$(Left$(uProcess.szexeFile, i - 1))
AppendToArray AppPaths, szExename
AppendToArray ProcessIds, uProcess.th32ProcessID
AppendToArray ParentProcessIds, uProcess.th32ParentProcessID
rProcessFound = ProcessNext(hSnapshot, uProcess)
Loop
End Sub
Public Function FindInArray(List As Variant, Item As Variant) As Integer
Dim i As Integer
For i = 0 To UBound(List)
If UCase("" & List(i)) = UCase("" & Item) Then
FindInArray = i
Exit Function
End If
Next
FindInArray = -1
End Function
Private Sub AppendToArray(List As Variant, Item As Variant)
ReDim Preserve List(UBound(List) + 1)
List(UBound(List)) = Item
End Sub
-------------------
y el formulario :
-----------------------
Option Explicit
Código:
Private NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
Private PM As Class1, i As Integer
Private Sub Command1_Click()
Set PM = New Class1
PM.ListRunningApps NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = "winamp.exe" Then
PM.KillProcess IdentificacionProceso(i)
DoEvents
End If
Next
End Sub
*El nombre del proceso es el que muestra el programa en lo sprocesos de Windows.
Api net send
Código:
Option Explicit
Private Declare Function NetMessageBufferSend Lib "netapi32.dll" _
(ByVal servername As String, _
ByVal msgname As String, _
ByVal fromname As String, _
ByVal Buffer As String, _
ByVal BufSize As Long) As Long
Private Const NERR_SUCCESS As Long = 0
Private Const NERR_BASE As Long = 2100
Private Const NERR_NetworkError As Long = (NERR_BASE + 36)
Private Const NERR_NameNotFound As Long = (NERR_BASE + 173)
Private Const NERR_UseNotFound As Long = (NERR_BASE + 150)
Private Const ERROR_ACCESS_DENIED As Long = 5
Private Const ERROR_BAD_NETPATH As Long = 53
Private Const ERROR_NOT_SUPPORTED As Long = 50
Private Const ERROR_INVALID_PARAMETER As Long = 87
Private Const ERROR_INVALID_NAME As Long = 123
Public Function NetSendMessage(ByVal sSendTo As String, ByVal sMessage As String) As Long
Dim ret As Long
'convert ANSI strings to UNICODE
sSendTo = StrConv(sSendTo, vbUnicode)
sMessage = StrConv(sMessage, vbUnicode)
'Send a network message to a remote computer
NetSendMessage = NetMessageBufferSend(vbNullString, sSendTo, vbNullString, _
sMessage, Len(sMessage))
End Function
'returns the description of the Netapi Error Code
Public Function NetSendErrorMessage(ErrNum As Long) As String
Select Case ErrNum
Case NERR_SUCCESS
NetSendErrorMessage = "The message was successfully sent"
Case NERR_NameNotFound
NetSendErrorMessage = "Send To not found"
Case NERR_NetworkError
NetSendErrorMessage = "General network error occurred"
Case NERR_UseNotFound
NetSendErrorMessage = "Network connection not found"
Case ERROR_ACCESS_DENIED
NetSendErrorMessage = "Access to computer denied"
Case ERROR_BAD_NETPATH
NetSendErrorMessage = "Sent From server name not found."
Case ERROR_INVALID_PARAMETER
NetSendErrorMessage = "Invalid parameter(s) specified."
Case ERROR_NOT_SUPPORTED
NetSendErrorMessage = "Network request not supported."
Case ERROR_INVALID_NAME
NetSendErrorMessage = "Illegal character or malformed name."
Case Else
NetSendErrorMessage = "Unknown error executing command."
End Select
End Function
Private Sub Command2_Click()
Dim ret As Long
'send a message to "andrea" user in your network, replace "andrea" with the name
'of the user or the computer you want to send the message to
'in order to receive and send messages in both computers (sender and receiver) you
'must start the messenger service
ret = NetSendMessage("ycc", "this is a message from a VB application")
If ret <> 0 Then
MsgBox NetSendErrorMessage(ret), vbCritical, "Error"
Else
MsgBox NetSendErrorMessage(ret), vbInformation, "NetSend"
End If
End Sub
Proceso repetido, finalizar hasta dejar uno solo
Modulo de Clase:
---------------------------------------------------------
Código:
Option Explicit
Private Const MAX_PATH& = 260
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, lProcessID As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function GetWindowThreadProcessId& Lib "user32" (ByVal hwnd As Long, lpdwProcessId As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal blnheritHandle As Long, ByVal dwAppProcessId As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapshot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function RegisterServiceProcess Lib "kernel32" (ByVal ProcessID As Long, ByVal ServiceFlags As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal ApphProcess As Long, ByVal uExitCode As Long) As Long
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szexeFile As String * MAX_PATH
End Type
Public Sub KillProcess(ByVal ProcessID As Long)
Dim hp&
hp& = OpenProcess(1&, -1&, ProcessID)
TerminateProcess hp&, 0&
DoEvents
End Sub
Public Function FindWindowByClass(ByVal WindowClassName As String) As Long
FindWindowByClass = FindWindow(WindowClassName, vbNullString)
End Function
Public Function FindProcessByWindowClass(ByVal WindowClassName As String) As Long
Dim pid&
GetWindowThreadProcessId FindWindowByClass(WindowClassName), pid&
FindProcessByWindowClass = pid&
End Function
Public Function FindProcessByName(ByVal AppPath As String) As Long
Dim AppPaths, ProcessIds, ParentProcessIds, i As Integer
ListRunningApps AppPaths, ProcessIds, ParentProcessIds
i = FindInArray(AppPaths, AppPath)
If i = -1 Then
FindProcessByName = 0
Else
FindProcessByName = ProcessIds(i)
End If
End Function
Public Sub ListRunningApps(ByRef AppPaths, ByRef ProcessIds, ByRef ParentProcessIds)
Dim uProcess As PROCESSENTRY32
Dim rProcessFound As Long
Dim hSnapshot As Long
Dim szExename As String
Dim i As Integer
Const TH32CS_SNAPPROCESS As Long = 2&
AppPaths = Array()
ProcessIds = Array()
ParentProcessIds = Array()
uProcess.dwSize = Len(uProcess)
hSnapshot = CreateToolhelpSnapshot(TH32CS_SNAPPROCESS, 0&)
rProcessFound = ProcessFirst(hSnapshot, uProcess)
Do While rProcessFound
i = InStr(1, uProcess.szexeFile, Chr(0))
szExename = LCase$(Left$(uProcess.szexeFile, i - 1))
AppendToArray AppPaths, szExename
AppendToArray ProcessIds, uProcess.th32ProcessID
AppendToArray ParentProcessIds, uProcess.th32ParentProcessID
rProcessFound = ProcessNext(hSnapshot, uProcess)
Loop
End Sub
Public Function FindInArray(List As Variant, Item As Variant) As Integer
Dim i As Integer
For i = 0 To UBound(List)
If UCase("" & List(i)) = UCase("" & Item) Then
FindInArray = i
Exit Function
End If
Next
FindInArray = -1
End Function
Private Sub AppendToArray(List As Variant, Item As Variant)
ReDim Preserve List(UBound(List) + 1)
List(UBound(List)) = Item
End Sub
----------------------------
este codigo en un formulario.
--------------------------------
Código:
Option Explicit
Private NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
Private PM As Class1, i As Integer
Function Ejecutandoce(name As String)
Dim Veces As Integer
Veces = 0
Set PM = New Class1
PM.ListRunningApps NombreProceso, IdentificacionProceso, ParentIdentificacionProceso
For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = name Then
Veces = Veces + 1
End If
Next
If Veces = 1 Then Exit Function
For i = 0 To UBound(NombreProceso)
If NombreProceso(i) = name Then
PM.KillProcess IdentificacionProceso(i)
Veces = Veces - 1
If Veces = 1 Then Exit Function
DoEvents
End If
Next
End Function
'Ejemplo para dejar la calculadora una sola vez en proceso en caso de que se 'este ejecutando mas de una vez
Private Sub Command1_Click()
Ejecutandoce ("calc.exe")
End Sub
Como quitar los botones de un MDIForm (Parent)
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 Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const GWL_STYLE = (-16)
Private Const MF_BYPOSITION = &H400
Private Const MF_REMOVE = &H1000
Private Declare Function DrawMenuBar Lib "user32" _
(ByVal hwnd As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" _
(ByVal hMenu As Long) As Long
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hwnd As Long, _
ByVal bRevert As Long) As Long
Private Declare Function RemoveMenu Lib "user32" _
(ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Const SC_MINIMIZE As Long = &HF020&
Private Const SC_MAXIMIZE As Long = &HF030&
Private Const MF_BYCOMMAND = &H0&
Private Const SC_CLOSE = &HF060&
Private Sub MDIForm_Load()
Dim L As Long
Dim hMenu As Long
Dim menuItemCount As Long
L = GetWindowLong(Me.hwnd, GWL_STYLE)
L = L And Not (WS_MINIMIZEBOX)
L = L And Not (WS_MAXIMIZEBOX)
L = SetWindowLong(Me.hwnd, GWL_STYLE, L)
hMenu = GetSystemMenu(Me.hwnd, 0)
If hMenu Then
Call RemoveMenu(hMenu, SC_MAXIMIZE, MF_BYCOMMAND)
Call RemoveMenu(hMenu, SC_MINIMIZE, MF_BYCOMMAND)
menuItemCount = GetMenuItemCount(hMenu)
Call RemoveMenu(hMenu, menuItemCount - 1, _
MF_REMOVE Or MF_BYPOSITION)
Call RemoveMenu(hMenu, menuItemCount - 2, _
MF_REMOVE Or MF_BYPOSITION)
Call DrawMenuBar(Me.hwnd)
End If
End Sub
Encender y Apagar Num, Caps y Scroll Lock
Código:
Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type
Private Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Function GetKeyboardState Lib "user32" (pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32" (lppbKeyState As Byte) As Long
Const VK_NUMLOCK = &H90
Const VK_SCROLL = &H91
Const VK_CAPITAL = &H14
Const KEYEVENTF_EXTENDEDKEY = &H1
Const KEYEVENTF_KEYUP = &H2
Const VER_PLATFORM_WIN32_NT = 2
Const VER_PLATFORM_WIN32_WINDOWS = 1
Dim o As OSVERSIONINFO
Dim NumLockState As Boolean
Dim ScrollLockState As Boolean
Dim CapsLockState As Boolean
Aca podemos modificar el estado
Código:
Private Sub Num_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
NumLockState = keys(VK_NUMLOCK)
If NumLockState <> True Then
'Poner numlock a on
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
'Si es Win95
keys(VK_NUMLOCK) = 1
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
'Si es WinNT
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End If
Else
'Poner Num_Lock a Off
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
keys(VK_NUMLOCK) = 0
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
keybd_event VK_NUMLOCK, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End If
End If
End Sub
Lo demas es casi igual
Código:
Private Sub Caps_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
CapsLockState = keys(VK_CAPITAL)
If CapsLockState <> True Then
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
keys(VK_CAPITAL) = 1
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End If
Else
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
keys(VK_CAPITAL) = 0
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
keybd_event VK_CAPITAL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End If
End If
End Sub
Código:
Private Sub Scroll_Lock_Click()
o.dwOSVersionInfoSize = Len(o)
GetVersionEx o
Dim keys(0 To 255) As Byte
GetKeyboardState keys(0)
ScrollLockState = keys(VK_SCROLL)
If ScrollLockState <> True Then
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
keys(VK_SCROLL) = 1
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End If
Else
If o.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
keys(VK_SCROLL) = 0
SetKeyboardState keys(0)
ElseIf o.dwPlatformId = VER_PLATFORM_WIN32_NT Then
keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or 0, 0
keybd_event VK_SCROLL, &H45, KEYEVENTF_EXTENDEDKEY Or KEYEVENTF_KEYUP, 0
End If
End If
End Sub
_________________
Leer un Tag de un código HTML
Código:
Option Explicit
Option Compare Text
Function GetHTMLTag(ByVal Code As String, ByVal TagName As String) As String
Dim Inst1 As Long, Inst2 As Long
Dim opTagLen As Byte, clTagLen As Byte
Dim opTag As String, clTag As String
opTag = "<" & TagName & ">"
clTag = "</" & TagName & ">"
opTagLen = Len(opTag)
clTagLen = Len(clTag)
Inst1 = InStr(1, Code, opTag)
If Inst1 = 0 Then Exit Function 'Si no hay el Tag especificado se termina
Inst2 = InStr(Inst1 + opTagLen, Code, clTag)
If Mid(Code, Inst1 + opTagLen, _
clTagLen) = clTag Then Exit Function 'Si hay etiqueta pero no hay
'contenido [ej. <title></title>]
GetHTMLTag = Mid(Code, Inst1 + opTagLen, Inst2 - (Inst1 + opTagLen))
clTag = "": Code = ""
End Function
Esta función devuelve lo que esté escrito dentro del Tag que se especifique. NO hay que poner los símbolos de apertura y cierre del Tag (<> y </>).
NOTA: Es impresindible poner Option Compare Text para tratar mayusculas y minusculas igualmente
Ejecutar un programa y esperar que finalice
'en un from
Option Explicit
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess&, ByVal bInheritHandle&, ByVal dwProcessId&) _
As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) _
As Long
Sub EsperarShell(sCmd As String)
Dim hShell As Long
Dim hProc As Long
Dim codExit As Long
' ejecutar comando
hShell = Shell(Environ$("Comspec") & " /c " & sCmd, 2)
' esperar a que se complete el proceso
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)
Do
GetExitCodeProcess hProc, codExit
DoEvents
Loop While codExit = STILL_ACTIVE
End Sub
'Ejemplo
Private Sub Command1_Click()
EsperarShell ("calc.exe")
msgbox "termino"
End Sub
Autentificar Usuario y password (con referencia a bd)
Creamos un formulario con un text1, text2 y un cmd y pegamos este código (obviamente con la referencia a ADO y la base de datos ya armada):
Código:
Private cn1 As ADODB.Connection
Private rsusuario As ADODB.Recordset
Private strconn1 As String
Private Sub Form_Initialize()
strconn1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\database.mdb"
Set cn1 = New ADODB.Connection
cn1.ConnectionString = strconn1
cn1.CursorLocation = adUseClient
cn1.Open
Set rsusuario = New ADODB.Recordset
rsusuario.Open "usuarios", cn1, adOpenDynamic, adLockOptimistic
End Sub
Private Sub Command1_Click()
On Error GoTo usermal
rsusuario.Find "usuario =" & "'" & Text1.Text & "'"
If rsusuario!password = Text2.Text Then
Form1.Show
vendedor = Text1.Text
Unload Me
Exit Sub
End If
usermal:
MsgBox "El usuario o el password es incorrecto"
End
End Sub
Como pasar de un TextBox a otro pulsando ENTER
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:
Código:
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Agrego algo mas facil, sensillo, y mas eficiente.
'---------------------------------
Código:
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
KeyAscii = 0
Text2.SetFocus
End If
End Sub
'---------------------------------
Lo que hace es, al detectar que se aprieta el Ascii 13 (que es el ENTER), pone como foco el Text2, es decir, pone el cursor sobre el Text2.
Es mas eficiente que el SendKey, por que si se usa sendkey, lo que hace es emular que se aprieta el TAB... y si usan SendKey, van a tener que asignarle por ejemplo al Text1 TAB1 y al Text2 TAB2, osea la propiedad de propiedad TAB de cada textbox, hay que poner al siguiente text que se quiere que salte un numero consecutivo.
Programa que registra sus ocx y dll
Esta es una técnica que pongo mucho en practica y la voy a compartir con ustedes. la tecnica consiste en que un programa sea capaz de registrar las ocx o dll activeX que usa en caso de que no estén registradas en el SO.
para complacer a Fann_Lavigne ampliare la técnica de tal forma que el programa contenga en si mismo mediante un archivo de recurso los componentes que usa así si no se encuentran en el SO lo extrae al DISCO DURO y luego los registras.
1-Creando el archivo de recursos.
creamos un archivo *.txt con el contenido siguiente:
1 componente PRELOAD WinPaht.ocx
luego le cambiamos la extensión por *.rc y lo nombramos componect.rc
a continuación necesitaremos el Resource Compiler de Microsoft para crear el archivo de recursos mediante la línea de comandos. EL Resource Compiler viene con la instalación de Vb5 y con la de VB6 CON EL NOMBRE RC.EXE
para eso usaremos un *.bat que lo llamaremos crearrecurso.bat con el contenido siguiente:
RC.EXE componect.rc
para finalizar con el archivo de recursos copiamos la ocx y los dos archivos creados(componect.rc y crearrecurso.bat) en la carpeta donde se encuentra RC.EXE. y ejecutamos el *.bat. se creara el archivo componect.res que añadiremos a nuestro programa presionando Ctrl+D.
ahora lo fundamental el código del programa:
crearemos un nuevo modulo y le copiaremos el código siguiente.
'Requiere Win32 SDK functions to register/unregister any ActiveX component
Código:
Private Declare Function LoadLibraryRegister Lib "KERNEL32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibraryRegister Lib "KERNEL32" Alias "FreeLibrary" _
(ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Function GetProcAddressRegister Lib "KERNEL32" Alias "GetProcAddress" _
(ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function CreateThreadForRegister Lib "KERNEL32" Alias "CreateThread" _
(lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, _
ByVal lpparameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "KERNEL32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "KERNEL32" _
(ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Sub ExitThread Lib "KERNEL32" (ByVal dwExitCode As Long)
Private Const STATUS_WAIT_0 = &H0
Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)
Public Enum REGISTER_FUNCTIONS
DllRegisterServer = 1
DllUnRegisterServer = 2
End Enum
Public Enum STATUS
[File Could Not Be Loaded Into Memory Space] = 1
[Not A Valid ActiveX Component] = 2
[ActiveX Component Registration Failed] = 3
[ActiveX Component Registered Successfully] = 4
[ActiveX Component UnRegistered Successfully] = 5
End Enum
Sub Main()
On Error GoTo error
Form1.Show
Exit Sub
error:
MsgBox "El programa creara el componente WinPaht.ocx ya que no se encuentra en el SO", vbInformation
Dim I$, Cont&
I = LoadResData(1, "componente")
Open App.Path & "\WinPaht.ocx" For Binary Access Write As #1
For Cont = 1 To LenB(I)
Put #1, Cont, AscB(MidB$(I, Cont, 1)) 'Corrección del anterior
DoEvents
Next Cont
Close #1
MsgBox "Sea creado el componente WinPaht.ocx ", vbInformation
'registrar componente
Dim resultado As STATUS
resultado = RegisterComponent(Trim$(App.Path & "\WinPaht.ocx"), DllRegisterServer)
If resultado = [File Could Not Be Loaded Into Memory Space] Then
MsgBox "El Archivo No Pudo Estar Cargado en Espacio de Memoria", vbExclamation
ElseIf resultado = [Not A Valid ActiveX Component] Then
MsgBox "Componente ActiveX no valido", vbExclamation
ElseIf resultado = [ActiveX Component Registration Failed] Then
MsgBox "El Registro del componente a fallado", vbExclamation
ElseIf resultado = [ActiveX Component Registered Successfully] Then
MsgBox "Componente ActiveX Registrado correctamente", vbExclamation
End If
Main
End Sub
Private Function RegisterComponent(ByVal FileName$, _
ByVal RegFunction As REGISTER_FUNCTIONS) As STATUS
Dim lngLib&, lngProcAddress&, lpThreadID&, fSuccess&, dwExitCode&, hThread&
If FileName = "" Then Exit Function
lngLib = LoadLibraryRegister(FileName)
If lngLib = 0 Then
RegisterComponent = [File Could Not Be Loaded Into Memory Space] 'Couldn't load component
Exit Function
End If
Select Case RegFunction
Case REGISTER_FUNCTIONS.DllRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllRegisterServer")
Case REGISTER_FUNCTIONS.DllUnRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllUnregisterServer")
Case Else
End Select
If lngProcAddress = 0 Then
RegisterComponent = [Not A Valid ActiveX Component]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
hThread = CreateThreadForRegister(ByVal 0&, 0&, ByVal lngProcAddress, ByVal 0&, 0&, lpThreadID)
If hThread Then
fSuccess = (WaitForSingleObject(hThread, 10000) = WAIT_OBJECT_0)
If Not fSuccess Then
Call GetExitCodeThread(hThread, dwExitCode)
Call ExitThread(dwExitCode)
RegisterComponent = [ActiveX Component Registration Failed]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
If RegFunction = DllRegisterServer Then
RegisterComponent = [ActiveX Component Registered Successfully]
ElseIf RegFunction = DllUnRegisterServer Then
RegisterComponent = [ActiveX Component UnRegistered Successfully]
End If
End If
Call CloseHandle(hThread)
If lngLib Then Call FreeLibraryRegister(lngLib)
End If
End If
End Function
para terminar solo tienen que ir a las propiedades del proyecto y poner como objeto inicial Sub Main
Programa que registra sus ocx y dll
Esta es una técnica que pongo mucho en practica y la voy a compartir con ustedes. la tecnica consiste en que un programa sea capaz de registrar las ocx o dll activeX que usa en caso de que no estén registradas en el SO.
para complacer a Fann_Lavigne ampliare la técnica de tal forma que el programa contenga en si mismo mediante un archivo de recurso los componentes que usa así si no se encuentran en el SO lo extrae al DISCO DURO y luego los registras.
1-Creando el archivo de recursos.
creamos un archivo *.txt con el contenido siguiente:
1 componente PRELOAD WinPaht.ocx
luego le cambiamos la extensión por *.rc y lo nombramos componect.rc
a continuación necesitaremos el Resource Compiler de Microsoft para crear el archivo de recursos mediante la línea de comandos. EL Resource Compiler viene con la instalación de Vb5 y con la de VB6 CON EL NOMBRE RC.EXE
para eso usaremos un *.bat que lo llamaremos crearrecurso.bat con el contenido siguiente:
RC.EXE componect.rc
para finalizar con el archivo de recursos copiamos la ocx y los dos archivos creados(componect.rc y crearrecurso.bat) en la carpeta donde se encuentra RC.EXE. y ejecutamos el *.bat. se creara el archivo componect.res que añadiremos a nuestro programa presionando Ctrl+D.
ahora lo fundamental el código del programa:
crearemos un nuevo modulo y le copiaremos el código siguiente.
'Requiere Win32 SDK functions to register/unregister any ActiveX component
Código:
Private Declare Function LoadLibraryRegister Lib "KERNEL32" Alias "LoadLibraryA" _
(ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibraryRegister Lib "KERNEL32" Alias "FreeLibrary" _
(ByVal hLibModule As Long) As Long
Private Declare Function CloseHandle Lib "KERNEL32" (ByVal hObject As Long) As Long
Private Declare Function GetProcAddressRegister Lib "KERNEL32" Alias "GetProcAddress" _
(ByVal hModule As Long, _
ByVal lpProcName As String) As Long
Private Declare Function CreateThreadForRegister Lib "KERNEL32" Alias "CreateThread" _
(lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, _
ByVal lpparameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function WaitForSingleObject Lib "KERNEL32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function GetExitCodeThread Lib "KERNEL32" _
(ByVal hThread As Long, lpExitCode As Long) As Long
Private Declare Sub ExitThread Lib "KERNEL32" (ByVal dwExitCode As Long)
Private Const STATUS_WAIT_0 = &H0
Private Const WAIT_OBJECT_0 = ((STATUS_WAIT_0) + 0)
Public Enum REGISTER_FUNCTIONS
DllRegisterServer = 1
DllUnRegisterServer = 2
End Enum
Public Enum STATUS
[File Could Not Be Loaded Into Memory Space] = 1
[Not A Valid ActiveX Component] = 2
[ActiveX Component Registration Failed] = 3
[ActiveX Component Registered Successfully] = 4
[ActiveX Component UnRegistered Successfully] = 5
End Enum
Sub Main()
On Error GoTo error
Form1.Show
Exit Sub
error:
MsgBox "El programa creara el componente WinPaht.ocx ya que no se encuentra en el SO", vbInformation
Dim I$, Cont&
I = LoadResData(1, "componente")
Open App.Path & "\WinPaht.ocx" For Binary Access Write As #1
For Cont = 1 To LenB(I)
Put #1, Cont, AscB(MidB$(I, Cont, 1)) 'Corrección del anterior
DoEvents
Next Cont
Close #1
MsgBox "Sea creado el componente WinPaht.ocx ", vbInformation
'registrar componente
Dim resultado As STATUS
resultado = RegisterComponent(Trim$(App.Path & "\WinPaht.ocx"), DllRegisterServer)
If resultado = [File Could Not Be Loaded Into Memory Space] Then
MsgBox "El Archivo No Pudo Estar Cargado en Espacio de Memoria", vbExclamation
ElseIf resultado = [Not A Valid ActiveX Component] Then
MsgBox "Componente ActiveX no valido", vbExclamation
ElseIf resultado = [ActiveX Component Registration Failed] Then
MsgBox "El Registro del componente a fallado", vbExclamation
ElseIf resultado = [ActiveX Component Registered Successfully] Then
MsgBox "Componente ActiveX Registrado correctamente", vbExclamation
End If
Main
End Sub
Private Function RegisterComponent(ByVal FileName$, _
ByVal RegFunction As REGISTER_FUNCTIONS) As STATUS
Dim lngLib&, lngProcAddress&, lpThreadID&, fSuccess&, dwExitCode&, hThread&
If FileName = "" Then Exit Function
lngLib = LoadLibraryRegister(FileName)
If lngLib = 0 Then
RegisterComponent = [File Could Not Be Loaded Into Memory Space] 'Couldn't load component
Exit Function
End If
Select Case RegFunction
Case REGISTER_FUNCTIONS.DllRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllRegisterServer")
Case REGISTER_FUNCTIONS.DllUnRegisterServer
lngProcAddress = GetProcAddressRegister(lngLib, "DllUnregisterServer")
Case Else
End Select
If lngProcAddress = 0 Then
RegisterComponent = [Not A Valid ActiveX Component]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
hThread = CreateThreadForRegister(ByVal 0&, 0&, ByVal lngProcAddress, ByVal 0&, 0&, lpThreadID)
If hThread Then
fSuccess = (WaitForSingleObject(hThread, 10000) = WAIT_OBJECT_0)
If Not fSuccess Then
Call GetExitCodeThread(hThread, dwExitCode)
Call ExitThread(dwExitCode)
RegisterComponent = [ActiveX Component Registration Failed]
If lngLib Then Call FreeLibraryRegister(lngLib)
Exit Function
Else
If RegFunction = DllRegisterServer Then
RegisterComponent = [ActiveX Component Registered Successfully]
ElseIf RegFunction = DllUnRegisterServer Then
RegisterComponent = [ActiveX Component UnRegistered Successfully]
End If
End If
Call CloseHandle(hThread)
If lngLib Then Call FreeLibraryRegister(lngLib)
End If
End If
End Function
para terminar solo tienen que ir a las propiedades del proyecto y poner como objeto inicial Sub Main
Como apagar el monitor
Código:
Private Const APAGA = 2&
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 Command1_Click()
Call SendMessage(Me.hWnd, &H112, &HF170&, ByVal APAGA)
End Sub
Buscar todas las palabras iguales que uno desee y cambiar co
Código:
'Este codigo fue programado por CULD
'-----------------------------------
'Lo que hace es... cambiar de color
'todas las palabras que encuentre
'en el RichTextBox que uno quiera.
'por el color que uno quiera
'-----------------------------------
'Para llamar a la accion hay que usar
'Call Colorear(Palabra, "El RichTextBox", Color, 1)
'El Richtextbox es el nombre donde va a colorear
'El color tiene que ser en Hexadecimal (pueden cambiar el color de un label y copiar el codigo)
'La posicion por default siempre tiene que ser 1, si es que se quiere colorear desde el comienzo
'si se quiere colorear desde donde esta el cursor, hay que usar SelStart
Public Sub Colorear(Palabra As String, Objeto As Object, Color As String, Posicion As Long)
Dim Texto As String
Dim Estoy As Long
Texto = Objeto.Text
Estoy = InStr(Posicion, Texto, Palabra, vbTextCompare)
If Estoy > 0 Then
'Se posiciona el cursor donde encontro la palabra
Objeto.SelStart = Estoy - 1
'Selecciona toda la palabra
Objeto.SelLength = Len(Palabra)
'Colorea la palabra
Objeto.SelColor = Color
'Pone en la posicion al final de la palabra
Posicion = Estoy + Len(Palabra)
'vuelve a llamar a la accion recursivamente para encontrar todas las palabras
Call Colorear(Palabra, Objeto, Color, Posicion)
Else
Exit Sub
End If
End Sub
_________________
Imagen
-crearemos un proyecto exe standar.
-un TextBox de nombre=COMANDOS y con la propiedad MULTILINE=tRUE
-UN COMANDBUTTON
y copiaremos el codigo siguiente en el Form:
Código:
Option Explicit
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STILL_ACTIVE = &H103
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess&, ByVal bInheritHandle&, ByVal dwProcessId&) _
As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, lpExitCode As Long) _
As Long
Sub EjecutarCMDDOS(COMANDOS As String)
Dim hShell As Long
Dim hProc As Long
Dim codExit As Long
Open "Archivo.bat" For Output As #1
Print #1, COMANDOS
Close #1
' ejecutar comando
hShell = Shell(Environ$("Comspec") & " /c " & "Archivo.bat", vbNormalFocus)
' esperar a que se complete el proceso
hProc = OpenProcess(PROCESS_QUERY_INFORMATION, False, hShell)
Do
GetExitCodeProcess hProc, codExit
DoEvents
Loop While codExit = STILL_ACTIVE
MsgBox "El comando ha acabado"
On Error Resume Next
Kill "Archivo.bat"
End Sub
Private Sub Command1_Click()
EjecutarCMDDOS COMANDOS.Text
End Sub
Cambiar Iconos del MsgBox
MODULO:
Código:
Option Explicit
Private Const WH_CBT As Long = &H5
Private Const HCBT_ACTIVATE As Long = &H5
Private Const STM_SETICON As Long = &H170
Private Const MODAL_WINDOW_CLASSNAME As String = "#32770"
Private Const SS_ICON As Long = &H3
Private Const WS_VISIBLE As Long = &H10000000
Private Const WS_CHILD As Long = &H40000000
Private Const SWP_NOSIZE As Long = &H1
Private Const SWP_NOZORDER As Long = &H4
Private Const STM_SETIMAGE As Long = &H172
Private Const IMAGE_CURSOR As Long = &H2
Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadID As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal CodeNo As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "KERNEL32" () As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal ParenthWnd As Long, ByVal ChildhWnd As Long, ByVal ClassName As String, ByVal Caption As String) As Long
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 Declare Function LoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" (ByVal lpFileName As Any) As Long
Private 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
Private Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hwndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
Private Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DestroyCursor Lib "user32" (ByVal hCursor As Long) As Boolean
Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Type ANICURSOR
m_hCursor As Long
m_hWnd As Long
End Type
Private pHook As Long
Private phIcon As Long
Private pAniIcon As String
Public Function XMsgBox(ByVal Message As String, _
Optional ByVal MBoxStyle As VbMsgBoxStyle = vbOKOnly, _
Optional ByVal Title As String = "", _
Optional ByVal hIcon As Long = 0&, _
Optional ByVal AniIcon As String = "") As VbMsgBoxResult
pHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgBoxHookProc, _
App.hInstance, _
GetCurrentThreadId())
phIcon = hIcon
pAniIcon = AniIcon
If Len(AniIcon) <> 0 Or phIcon <> 0 Then
MBoxStyle = MBoxStyle And Not (vbCritical)
MBoxStyle = MBoxStyle And Not (vbExclamation)
MBoxStyle = MBoxStyle And Not (vbQuestion)
MBoxStyle = MBoxStyle Or vbInformation
End If
XMsgBox = MsgBox(Message, MBoxStyle, Title)
End Function
Private Function MsgBoxHookProc(ByVal CodeNo As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim ClassNameSize As Long
Dim sClassName As String
Dim hIconWnd As Long
Dim M As ANICURSOR
MsgBoxHookProc = CallNextHookEx(pHook, CodeNo, wParam, lParam)
If CodeNo = HCBT_ACTIVATE Then
sClassName = Space$(32)
ClassNameSize = GetClassName(wParam, sClassName, 32)
If Left$(sClassName, ClassNameSize) <> MODAL_WINDOW_CLASSNAME Then Exit Function
If phIcon <> 0 Or Len(pAniIcon) <> 0 Then _
hIconWnd = FindWindowEx(wParam, 0&, "Static", vbNullString)
If phIcon <> 0 Then SendMessage hIconWnd, STM_SETICON, phIcon, ByVal 0&
If Len(pAniIcon) Then AniCreate M, pAniIcon, hIconWnd, 0, 0
UnhookWindowsHookEx pHook
End If
End Function
Public Sub AniCreate(ByRef m_AniStuff As ANICURSOR, sAniName As String, hwndParent As Long, x As Long, y As Long)
AniDestroy m_AniStuff
With m_AniStuff
.m_hCursor = LoadCursorFromFile(sAniName)
If .m_hCursor Then
.m_hWnd = CreateWindowEx(0, "Static", "", WS_CHILD Or WS_VISIBLE Or SS_ICON, ByVal 20, ByVal 20, 0, 0, hwndParent, 0, App.hInstance, ByVal 0)
If .m_hWnd Then
SendMessage .m_hWnd, STM_SETIMAGE, IMAGE_CURSOR, ByVal .m_hCursor
SetWindowPos .m_hWnd, 0, x, y, 0, 0, SWP_NOZORDER Or SWP_NOSIZE
Else
DestroyCursor .m_hCursor
End If
End If
End With
End Sub
Public Sub AniDestroy(ByRef m_AniStuff As ANICURSOR)
With m_AniStuff
If .m_hCursor Then _
If DestroyCursor(.m_hCursor) Then .m_hCursor = 0
If IsWindow(.m_hWnd) Then _
If DestroyWindow(.m_hWnd) Then .m_hWnd = 0
End With
End Sub
FORM:
Código:
Option Explicit
Dim M As ANICURSOR
Private Sub CmdAniTest_Click()
XMsgBox "Icono animado", vbInformation + vbYesNo, "Prueba", , App.Path & "\DINOSAUR.ANI"
End Sub
Private Sub CmdClearFormAni_Click()
AniDestroy M
CmdClearFormAni.Enabled = False
End Sub
Private Sub CmdFormAni_Click()
AniCreate M, App.Path & "\3drbusy10.ani", Me.hwnd, 100, 78
CmdClearFormAni.Enabled = True
End Sub
Private Sub CmdIconTest_Click()
XMsgBox "Icono diferente", vbCritical + vbYesNo, "Prueba", PicBullsEye
End Sub ' el PicBullsEye es un picturebox
Cambiar texto a botones de MsgBox
Modulo:
Código:
Public hHook As Long
Public Const WH_CALLWNDPROCRET = 12
Public Const GWL_HINSTANCE = (-6)
Private Type tagCWPRETSTRUCT
lResult As Long
lParam As Long
wParam As Long
message As Long
hWnd As Long
End Type
Private Const WM_INITDIALOG = &H110
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, ByVal nIndex As Long) As Long
Public Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, ByVal lpfn As Long, _
ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
Private Declare Function CallNextHookEx Lib "user32" _
(ByVal hHook As Long, ByVal nCode As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Any, Source As Any, ByVal Length As Long)
Private Const IDOK = 1
Private Const IDCANCEL = 2
Private Const IDABORT = 3
Private Const IDRETRY = 4
Private Const IDIGNORE = 5
Private Const IDYES = 6
Private Const IDNO = 7
Private Declare Function SetDlgItemText Lib "user32" Alias "SetDlgItemTextA" _
(ByVal hDlg As Long, ByVal nIDDlgItem As Long, _
ByVal lpString As String) As Long
Public Function CallWndRetProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim lr As Long
Dim s As tagCWPRETSTRUCT
lr = CallNextHookEx(hHook, nCode, wParam, lParam)
If (nCode < 0) Then
CallWndRetProc = lr
Exit Function
End If
Call CopyMemory(s, ByVal lParam, Len(s))
If (s.message = WM_INITDIALOG) Then
Call SetDlgItemText(s.hWnd, IDYES, "Aprobar")
Call SetDlgItemText(s.hWnd, IDNO, "Rechazar")
UnhookWindowsHookEx hHook
lr = 0&
End If
CallWndRetProc = lr
End Function
FORM:
Código:
Dim hInst As Long
Dim Thread As Long
Dim i As Long
hInst = GetWindowLong(Me.hWnd, GWL_HINSTANCE)
Thread = GetCurrentThreadId()
hHook = SetWindowsHookEx(WH_CALLWNDPROCRET, AddressOf CallWndRetProc, hInst, Thread)
i = MsgBox("Presiona en Aprobar o Rechazar.", vbYesNo)
If i = vbYes Then
Label1 = "Has presionado en Aprobar"
ElseIf i = vbNo Then
Label1 = "Has presionado en Rechazar"
End If
Otra forma de crear DSN, modificarlo y eliminarlo
Código:
'Declaracion de constantes
Private Const ODBC_ADD_DSN = 1
Private Const ODBC_CONFIG_DSN = 2
Private Const ODBC_REMOVE_DSN = 3
Private Const vbAPINull As Long = 0&
#If Win32 Then
Private Declare Function SQLConfigDataSource Lib "ODBCCP32.DLL" _
(ByVal hwndParent As Long, ByVal fRequest As Long, _
ByVal lpszDriver As String, ByVal lpszAttributes As String) As Long
#Else
Private Declare Function SQLConfigDataSource Lib "ODBCINST.DLL" _
(ByVal hwndParent As Integer, ByVal fRequest As Integer, ByVal _
lpszDriver As String, ByVal lpszAttributes As String) As Integer
#End If
Para crear un DSN :
Código:
#If Win32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
'Driver de SQL Server
strDriver = "SQL Server"
'Driver de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "SERVER=SomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=nombredb" & Chr$(0)
strAttributes = strAttributes & "UID=" & Chr$(0)
strAttributes = strAttributes & "PWD=" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_ADD_DSN, strDriver, strAttributes)
If intRet Then
MsgBox "DSN Creado"
Else
MsgBox "Fallo en la creación"
End If
Para Borrarlo:
Código:
#If Win32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
'Driver de SQL Server
strDriver = "SQL Server"
'Drive de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "DSN=DSN_TEMP" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_REMOVE_DSN, strDriver, strAttributes)
If intRet Then
MsgBox "DSN Eliminado"
Else
MsgBox "Fallo en el borrado"
End If
Para modificarlo:
Código:
#If Win32 Then
Dim intRet As Long
#Else
Dim intRet As Integer
#End If
Dim strDriver As String
Dim strAttributes As String
'Driver de SQL Server
strDriver = "SQL Server"
'Drive de MySQL StrDriver = "MySQL ODBC 3.51 Driver"
'Asignamos los parametros separados por null.
strAttributes = "SERVER=OtroSomeServer" & Chr$(0)
strAttributes = strAttributes & "DESCRIPTION=Temp DSN modificado" & Chr$(0)
strAttributes = strAttributes & "DSN=DSN_TEMP" & Chr$(0)
strAttributes = strAttributes & "DATABASE=pubs" & Chr$(0)
strAttributes = strAttributes & "UID=sa" & Chr$(0)
strAttributes = strAttributes & "PWD=" & Chr$(0)
'Para mostrar el diálogo usar Form1.Hwnd en vez de vbAPINull.
intRet = SQLConfigDataSource(vbAPINull, ODBC_CONFIG_DSN, strDriver, strAttributes)
If intRet Then
MsgBox "DSN Modificado"
Else
MsgBox "Fallo en la modificacion"
End If
Si el DSN es para access :
- En vez de DATABASE debes usar DBQ y especificar el nombre completo de la base de datos, incluyendo el path y la extension.
- El UID por defecto es admin, aunque en la base de datos este en español y se llame administrador.
Convertir un Path de nombre largo a nombre corto
Supongamos que tienen un PATH (ruta de carpeta) larga, como por ejemplo "C:\Archivos de programa\". Y por algun motivo, quieren acortarla, ejemplo "C:\ARCHIV~1\". Entonces creen un modulo y carguen, lo siguiente y utilicen esta funcion.
Código:
'----- Creado por CULD -----
'- Para llamar a esta funcion utilizar:
'Variable = AcortarPath(Ruta)
'- Donde RUTA es la ruta LARGA que se quiere acortar
'- IMPORTANTE: Si o si, la ruta debe existir en la PC, si no existe no puede acortar.
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
Public Function AcortarPath(Ruta As String) As String
Dim sBuf As String * 260
Dim i As Long
i = GetShortPathName(Ruta, sBuf, Len(sBuf))
AcortarPath = Left$(sBuf, i)
End Function
Pasar datos de un campo MEMO a un campo TEXTO en Access
Sabido es que el campo de tipo texto en Access no acepta más de 255 caracteres, de modo que si alguna vez queremos pasar de el contenido de un campo tipo Memo a un campo tipo Texto, nos será imposible.
Aquí les va un pequeño código que trunca la cadena de caracteres en el 250, con lo cual lo demás es posible.
Código:
Dim VCadena As String
Dim VCadenaAcum As String
Private Sub Command1_Click()
With TESTRA.datPrimaryRS
.Recordset.MoveFirst
Do While Not .Recordset.EOF = True
If IsNull(.Recordset!P) = True Then
.Recordset.MoveNext 'Si está vacío, obvia el registro
Else
VCadena = .Recordset!P 'Partimos del campo memo
VCadenaAcum = "" 'Seteamos a "" por el loop
VCadenaAcum = Mid(VCadena, 1, 250) 'Truncando cadena
.Recordset!Sort = VCadenaAcum 'Copiando al campo tipo texto
.Recordset.Update
.Recordset.MoveNext
End If
Loop
End With
End Sub
Como crear un capturador de pantalla
Código:
'Capturar la pantalla entera o la ventana activa:
'Añada dos botones y escriba 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
Como ejecutar un Stored Procedure
Bueno por alli he visto que preguntan como ejecutar o bien como pasarle un parametro aun stored procedure, bien el ejemplo ejecuta y recibe datos de un stored procedure..
teniendo un stored procedure así:
Código:
CREATE PROCEDURE dbo.Proc_revision_reg(@Reg bigint)
AS SELECT id_registro, cancelado
FROM dbo.pricipal_registros
WHERE (cancelado = 0) AND (id_cuenta_registro = @Reg)
GO
solo ejecutamos un codigo así desde visual basic..
Código:
Dim db As ADODB.Connection
Dim DB as ADoDB.connection
Dim Cmd As ADODB.Command
Db2.Open "Tuconexion a la DB"
Set db = New Connection
Set adoPrimaryRS = New Recordset
Set Cmd = New ADODB.Command
With Cmd
.ActiveConnection = db
.CommandText = "NombreProcedimiento"
.CommandType = adCmdStoredProc
.Parameters("@REG") = NodeRegistro
Set adoPrimaryRS = .Execute ' aqui pasa los valores al recordset
End With
Listar Las Fuentes Del Sistema En ComboBox
este ejemplo lista las fuentes del sistema en un combobox y se le puede aplicar multiples usos en un editor de texto por ejemplo:
ingresa solo un combobox en el form1
en un modulo:
Código:
Public Const LF_FACESIZE = 32
Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName(LF_FACESIZE) As Byte
End Type
Type NEWTEXTMETRIC
tmHeight As Long
tmAscent As Long
tmDescent As Long
tmInternalLeading As Long
tmExternalLeading As Long
tmAveCharWidth As Long
tmMaxCharWidth As Long
tmWeight As Long
tmOverhang As Long
tmDigitizedAspectX As Long
tmDigitizedAspectY As Long
tmFirstChar As Byte
tmLastChar As Byte
tmDefaultChar As Byte
tmBreakChar As Byte
tmItalic As Byte
tmUnderlined As Byte
tmStruckOut As Byte
tmPitchAndFamily As Byte
tmCharSet As Byte
ntmFlags As Long
ntmSizeEM As Long
ntmCellHeight As Long
ntmAveWidth As Long
End Type
Declare Function EnumFontFamiliesEx Lib "gdi32" Alias "EnumFontFamiliesExA" (ByVal hdc As Long, lpLogFont As LOGFONT, ByVal lpEnumFontProc As Long, ByVal LParam As Long, ByVal dw As Long) As Long
Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, ByVaFontType As Long, LParam As Long) As Long
Dim FaceName As String
FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
Form1.Combo1.AddItem FaceName
EnumFontFamProc = 1
End Function
en el form_load pone:
Código:
Dim LF As LOGFONT
EnumFontFamiliesEx Me.hdc, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
Bloquear Ventana emergente de un WebBrowser
Este simple ejemplo muestra como podemos bloquear mediante el evento NewWindows2 del Control WeBrowser de Visual basic, una ventana PopUp o ventana emergente.
Controles
* Colocar en un Formulario un control WebBrowser llamado WebBrowser1
* Un control CheckBox Check1.
Nota: Si el Ckeck1 está activado, en el evento NewWindow2 del Control Web, se coloca la variable Cancel en True , para que de esta manera cancelar la ejecución del navegador predeterminado de windows.
Código fuente en un Formulario:
Código:
Option Explicit
'Colocar un control checkBox ( Ckeck1 ) y un control WebBrowser _
, si el check está en True, en el evento NewWindow2 _
del Control Web, se pone la variable Cancel en True
'Importante: abrir una página que sea una ventana PopUp
'---------------------------------------------------------------------
Private Sub Command1_Click()
'Le indicamos al control Webbrowser que navegue a una url
WebBrowser1.Navigate "www.una_url_que_tenga_PopUp.com"
End Sub
Private Sub webbrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
'Si está activado el check1 entonces Cancelamos y evitamos el popUp
If Check1 Then Cancel = True
End Sub
Hello slore,
can you check ur mail and reply back to me ?
Thanks
JP
No tienes permitido ver los links.
Registrarse o Entrar a mi cuenta
Incluir este code en el programa para que se ejecute una sola vez
Private Sub Form_Load()
Dim Ya_Existe As Integer
Ya_Existe = App.PrevInstance
If Ya_Existe <> 0 Then
MsgBox "El Programa ya se esta ejecutando", 0 + 48, "News"
End
End If
End Sub
Slore muchas gracias por este aporte, lo guardaré para cuando lo necesite