comment
IRC Chat
play_arrow
Este sitio utiliza cookies propias y de terceros. Si continúa navegando consideramos que acepta el uso de cookies. OK Más Información.

[VB6] Coleccion de Codigos Utiles

  • 82 Respuestas
  • 43826 Vistas

0 Usuarios y 4 Visitantes están viendo este tema.

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« 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
« Última modificación: Junio 08, 2012, 11:33:43 am por Slore »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #1 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
« Última modificación: Junio 13, 2012, 08:42:49 pm por ANTRAX »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #2 en: Junio 08, 2012, 11:32:45 am »
Como usar el Random en un programa

Código:
 
Código: No tienes permisos para ver links. Registrate o Entra con tu cuenta
Private Sub Form_Load()
  Dim Num As Double
  Randomize
  Num = Rnd
  MsgBox Num
End Sub
« Última modificación: Junio 08, 2012, 11:36:33 am por Slore »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #3 en: Junio 08, 2012, 11:33:02 am »
Saber desde que directorio se ejecuta mi aplicación
Código:
 
Código: No tienes permisos para ver links. Registrate o Entra con tu cuenta
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
« Última modificación: Junio 08, 2012, 11:36:51 am por Slore »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #4 en: Junio 08, 2012, 11:33:55 am »
Como verificar si un fichero existe
Código:
Código: No tienes permisos para ver links. Registrate o Entra con tu cuenta
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: No tienes permisos para ver links. Registrate o Entra con tu cuenta
Dim Archivo As String
Archivo = "C:\MiTexto.txt"
If Dir(Archivo, vbArchive) = "" Then
MsgBox "El Fichero No Existe"
End If
« Última modificación: Junio 08, 2012, 11:37:29 am por Slore »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #5 en: Junio 08, 2012, 11:34:40 am »
Como ingresar solo numeros en un campo de texto
Código:
 
Código: No tienes permisos para ver links. Registrate o Entra con tu cuenta
  If ((KeyAscii < 48 Or KeyAscii > 57) And (KeyAscii < 44 Or KeyAscii > 44)) Then
       If (KeyAscii <> 8) Then KeyAscii = 0
    End If
« Última modificación: Junio 08, 2012, 11:37:06 am por Slore »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #6 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: No tienes permisos para ver links. Registrate o Entra con tu cuenta
For Contador = Len(Texto) To 1 Step -1

Otxet = Otxet & Mid (Texto, Contador, 1)
Next Contador
« Última modificación: Junio 08, 2012, 11:38:34 am por Slore »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #7 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: No tienes permisos para ver links. Registrate o Entra con tu cuenta
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: No tienes permisos para ver links. Registrate o Entra con tu cuenta
Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
SendKeys "{tab}"
KeyAscii = 0
End If
End Sub
« Última modificación: Junio 08, 2012, 11:38:18 am por Slore »

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #8 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

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #9 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

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #10 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

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #11 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).

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #12 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

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #13 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"

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #14 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

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #15 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

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #16 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..

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #17 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

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #18 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)

Desconectado Slore

  • *
  • Underc0der
  • Mensajes: 172
  • Actividad:
    0%
  • Reputación 0
  • OrwaySoftware
    • Ver Perfil
    • Email
  • Skype: OrwaySoftware
« Respuesta #19 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;dbq=@dbname"

OLE DB


Standard:

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

UDL

UDL


UDL:

"File Name=c:\myDataLink.udl;"

 

¿Te gustó el post? COMPARTILO!