Underc0de - Hacking y seguridad informática

Programación General => Visual Basic => Códigos Fuentes => Mensaje iniciado por: Slore en Junio 08, 2012, 11:32:01 am

Título: [VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:32:01 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:32:23 am
Incluir este code en el programa para que se ejecute una sola vez

Código: Visual Basic
  1. Private Sub Form_Load()
  2. Dim Ya_Existe As Integer
  3. Ya_Existe = App.PrevInstance
  4. If Ya_Existe <> 0 Then
  5. MsgBox "El Programa ya se esta ejecutando", 0 + 48, "News"
  6. End
  7. End If
  8. End Sub
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:32:45 am
Como usar el Random en un programa

Código:
 
Código: [Seleccionar]
Private Sub Form_Load()
  Dim Num As Double
  Randomize
  Num = Rnd
  MsgBox Num
End Sub
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:33:02 am
Saber desde que directorio se ejecuta mi aplicación
Código:
 
Código: [Seleccionar]
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:33:55 am
Como verificar si un fichero existe
Código:
Código: [Seleccionar]
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:
Código: [Seleccionar]
Dim Archivo As String
Archivo = "C:\MiTexto.txt"
If Dir(Archivo, vbArchive) = "" Then
MsgBox "El Fichero No Existe"
End If
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:34:40 am
Como ingresar solo numeros en un campo de texto
Código:
 
Código: [Seleccionar]
  If ((KeyAscii < 48 Or KeyAscii > 57) And (KeyAscii < 44 Or KeyAscii > 44)) Then
       If (KeyAscii <> 8) Then KeyAscii = 0
    End If
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:34:57 am
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:
 
Código: [Seleccionar]
For Contador = Len(Texto) To 1 Step -1

Otxet = Otxet & Mid (Texto, Contador, 1)
Next Contador
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:35:44 am
Como pasar de un texto a otro usando Enter
Insertar tres TextBox y escribir el siguiente código:

Código:
Código: [Seleccionar]
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:
Código: [Seleccionar]
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:39:15 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:39:40 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:40:01 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:40:27 am
 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).
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:40:45 am
 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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:41:06 am
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"
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:41:40 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:42:12 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:42:40 am
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..
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:43:04 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:43:26 am
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)
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:43:47 am
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;[email protected]"

OLE DB


Standard:

"Provider=PervasiveOLEDB;Data Source=C:\path"

UDL

UDL


UDL:

"File Name=c:\myDataLink.udl;"
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:44:07 am
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.
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:44:24 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:44:44 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:45:21 am
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.
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:45:43 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:46:10 am
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)
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:46:24 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:46:57 am
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"
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:47:25 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:47:55 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:48:18 am
Ejecutar cualquier programa
Código:
Dim ret As String
ret = Shell("rundll32.exe url.dll,FileProtocolHandler " & ("ruta archivo"))
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:50:50 am
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)
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:51:14 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 11:51:42 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:14:27 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:15:06 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:15:24 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:15:48 pm
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

_________________
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:16:16 pm

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"
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:16:38 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:17:11 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 12:17:35 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:19:57 pm
 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


************************************************** *******
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:20:29 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:20:49 pm
 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)"
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:21:29 pm
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
' ************************************************** *************
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:21:47 pm
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")
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:22:14 pm
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:22:39 pm
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

_________________
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 08, 2012, 01:23:27 pm
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..
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Pekador en Junio 08, 2012, 04:55:09 pm
killer proces 3 ejemplos publicos

Código: [Seleccionar]
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 Sub


Código: [Seleccionar]
Có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


Código: [Seleccionar]
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:41:54 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:42:15 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:42:35 am
 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..
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:42:54 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:43:17 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:43:45 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:44:06 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:44:46 am
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.

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:47:13 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:47:38 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:47:59 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:48:43 am
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

_________________
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:49:03 am
 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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:49:26 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:49:48 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:57:29 am
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.

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 05:57:54 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:12:08 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:12:24 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:12:45 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:13:07 am
-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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:13:28 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:13:52 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:14:17 am
 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.
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:14:52 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:15:11 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:15:29 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:16:31 am
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
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:24:19 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Slore en Junio 09, 2012, 06:24:52 am
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

Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: fisher5 en Mayo 09, 2015, 10:21:45 am



Hello slore,

can you check ur mail and reply back to me ? 

Thanks

JP







Incluir este code en el programa para que se ejecute una sola vez

Código: Visual Basic
  1. Private Sub Form_Load()
  2. Dim Ya_Existe As Integer
  3. Ya_Existe = App.PrevInstance
  4. If Ya_Existe <> 0 Then
  5. MsgBox "El Programa ya se esta ejecutando", 0 + 48, "News"
  6. End
  7. End If
  8. End Sub
Título: Re:[VB6] Coleccion de Codigos Utiles
Publicado por: Seven of Nine en Julio 14, 2016, 09:01:56 pm
Slore muchas gracias por este aporte, lo guardaré para cuando lo necesite