• [VB6] Coleccion de Codigos Utiles

 #210592  por ANTRAX
 26 Jul 2010, 19:27
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: [ Debe registrarse para ver este enlace ]
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: [ Debe registrarse para ver este enlace ]
Dim LF As LOGFONT
EnumFontFamiliesEx Me.hdc, LF, AddressOf EnumFontFamProc, ByVal 0&, 0
 #210593  por ANTRAX
 26 Jul 2010, 19:28
Este es un efecto para simular un formulario 3d:
pone un boton en el form.
Código: [ Debe registrarse para ver este enlace ]
Public Sub ThreeDForm(frmForm As Form)

Const cPi = 3.1415926

Dim intLineWidth As Integer

intLineWidth = 5

Dim intSaveScaleMode As Integer

intSaveScaleMode = frmForm.ScaleMode

frmForm.ScaleMode = 3

Dim intScaleWidth As Integer

Dim intScaleHeight As Integer

intScaleWidth = frmForm.ScaleWidth

intScaleHeight = frmForm.ScaleHeight

frmForm.Cls

frmForm.Line (0, intScaleHeight)-(intLineWidth, 0), &HFFFFFF, BF

frmForm.Line (0, intLineWidth)-(intScaleWidth, 0), &HFFFFFF, BF

frmForm.Line (intScaleWidth, 0)-(intScaleWidth - intLineWidth, intScaleHeight), &H808080, BF

frmForm.Line (intScaleWidth, intScaleHeight - intLineWidth)-(0, intScaleHeight), &H808080, BF

Dim intCircleWidth As Integer

intCircleWidth = Sqr(intLineWidth * intLineWidth + intLineWidth * intLineWidth)

frmForm.FillStyle = 0

frmForm.FillColor = QBColor(15)

frmForm.Circle (intLineWidth, intScaleHeight - intLineWidth), intCircleWidth, QBColor(15), -3.1415926, -3.90953745777778

frmForm.Circle (intScaleWidth - intLineWidth, intLineWidth), intCircleWidth, QBColor(15), -0.78539815, -1.5707963

frmForm.Line (0, intScaleHeight)-(0, 0), 0

frmForm.Line (0, 0)-(intScaleWidth - 1, 0), 0

frmForm.Line (intScaleWidth - 1, 0)-(intScaleWidth - 1, intScaleHeight - 1), 0

frmForm.Line (0, intScaleHeight - 1)-(intScaleWidth - 1, intScaleHeight - 1), 0

frmForm.ScaleMode = intSaveScaleMode

End Sub


Private Sub Command1_Click()

ThreeDForm Me

End Sub

Private Sub Form_Resize()

ThreeDForm Me

End Sub
 #210597  por ANTRAX
 26 Jul 2010, 19:30
si tengo un programa que quiero que se ejecute en 800x600 y el ordenador en el que lo voy a ejecutar tiene puesto 1024x768, guardo en unas variables el 1024x768 y cambio la resulucion a 800x600, cuando el usuario salga o termine el programa se vuelve a cambiar a la que tenia puesta el usuario 1024x768.


VAMOS A USAR UN MODULO Y UN FORM.AL ABRIR EL PROGRAMA SE CAMBIARA LA RESOLUCION A 800X600 Y AL CERRAR LA VENTANA DEL FORM SE CAMBIARA A LA QUE TENIA EL PC(NATURALMENTE SI TIENES LA MISMA QUE EL EJEMPLO EL EFECTO NO SE NOTA).

COPIA ESTO EN UN MODULO LLAMALO COMO QUIERAS:
Código: [ Debe registrarse para ver este enlace ]
Private Declare Function EnumDisplaySettings Lib "user32" Alias "EnumDisplaySettingsA" _
(ByVal lpszDeviceName As Long, ByVal iModeNum As Long, lpDevMode As Any) As Boolean


Private Declare Function ChangeDisplaySettings Lib "user32" Alias "ChangeDisplaySettingsA" _
(lpDevMode As Any, ByVal dwflags As Long) As Long

Const CCDEVICENAME = 32
Const CCFORMNAME = 32
Const DM_PELSWIDTH = &H80000
Const DM_PELSHEIGHT = &H100000


Private Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Sub ChangeRes(iWidth As Single, iHeight As Single)

Dim DevM As DEVMODE
Dim a As Boolean
Dim i&
i = 0


Do
a = EnumDisplaySettings(0&, i&, DevM)
i = i + 1
Loop Until (a = False)

Dim b&

DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT
DevM.dmPelsWidth = iWidth
DevM.dmPelsHeight = iHeight

b = ChangeDisplaySettings(DevM, 0)

End Sub
COPIA ESTO EN UN FORM:
Código: [ Debe registrarse para ver este enlace ]
Public ancho As Single
Public alto As Single
Private Sub Form_Load()
'guardamos la resolucion actual en ancho y alto para
'luego volver a ponerla cuando se cierre el programa
'con la x

ancho = iWidth
alto = iHeight
'cambiamos la resolucion a 800x600

Call ChangeRes(800, 600)
End Sub

Private Sub Form_Unload(Cancel As Integer)'cuando se cierra el form
Call ChangeRes(ancho, alto)'devolvemos la resolucion guardada en ancho,alto

End Sub
 #210598  por ANTRAX
 26 Jul 2010, 19:31
Código: [ Debe registrarse para ver este enlace ]
Function ValidarCadena(Caractar As Integer, StrValida As String) As Integer
Dim Respuesta As Integer
Respuesta = Caractar
If Caractar > 26 Then
If InStr(StrValida, Chr(Caractar)) = 0 Then
Respuesta = 0
End If
End If
ValidarCadena = Respuesta
End Function

Private Sub txtvalidar_KeyPress(KeyAscii As Integer)
KeyAscii = ValidarCadena(KeyAscii, "01234567ABCDEF")
End Sub
 #210600  por ANTRAX
 26 Jul 2010, 19:32
Esta funcion sirve para cambiar la impresora del objeto Printer, conociendo el nombre por la cual se quiere cambiar.
Devuelve FALSE si no pudo cambiarla por que no la encontro.
Devuelve TRUE si se cambio correctamente.

IMPORTANTE: NO CAMBIA LA IMPRESORA PREDETERMINADA, SOLAMENTE LA DEL OBJETO PRINTER.
Código: [ Debe registrarse para ver este enlace ]
'========== Codigo realizado por CULD ==========
'============= [email protected] ===============
'Esta funcion cambia el objeto printer por la
'impresora que deseamos. Obviamente tenemos que
'conocer el nombre de la misma e ingresarlo correctamente
'===============================================
Public Function CambiarImpresora(Nombre As String) As Boolean
Dim Impresora As Printer 'creo un objeto para la impresora

For Each Impresora In Printers 'recorro todas las impresoras disponibles
    If UCase(Impresora.DeviceName) = UCase(Nombre) Then 'verifico si la impresora actual es la que quiero
        Set Printer = Impresora 'como encontre la impresora la asigno al objeto printer
        CambiarImpresora = True 'informo que se cambio correctamente
    End If
Next
CambiarImpresora = False 'no se encontro la impresora asi que no se pudo asignar
End Function
 #210603  por ANTRAX
 26 Jul 2010, 19:35
Código: [ Debe registrarse para ver este enlace ]
Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Código: [ Debe registrarse para ver este enlace ]
Dim Reply As Long
Reply = URLDownloadToFile(0, "http://dirección", "C:\archivo_destino", 0, 0)
If Reply = 0 Then
    'Descargado
Else
    'Error al descargar
End If
 #210606  por ANTRAX
 26 Jul 2010, 19:38
Código: [ Debe registrarse para ver este enlace ]
      Private Sub MDIForm_Resize()
      On Error Resume Next
      Dim ImageWidth As Single
      Dim ImageHeight As Single
      picStretch.Visible = False
      picStretch.AutoRedraw = True
      picStretch.Height = Me.ScaleHeight 'By Mirador
      ImageWidth = picStretch.ScaleX(picStretch.Picture.Width, vbHimetric, vbTwips)
      ImageHeight = picStretch.ScaleY(picStretch.Picture.Height, vbHimetric, vbTwips)
      picStretch.PaintPicture picStretch.Picture, 0, 0, Me.ScaleWidth, Me.ScaleHeight, 0, 0, ImageWidth, ImageHeight
      Set Me.Picture = picStretch.Image
      End Sub
En este caso, deberías tener un Picture llamado picStretch con la imagen que quieres que se ajuste a la ventana MDI.
 #210610  por ANTRAX
 26 Jul 2010, 19:40
Código: [ Debe registrarse para ver este enlace ]
Private Sub Text1_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub
Lo que hace es al presionar una tecla en el textbox, en vez de escribir esa tecla la cambia por otra...
1- vuelve a chr (osea caracter) la tecla presionada...
2- Transforma en mayuscula ese chr (osea la letra) (nota: si ya esta en mayuscula obviamente lo deja asi, y si la letra es un caracter raro queno tiene mayuscula lo deja igual)
3- Vuelve a generar el ascii de esa letra en "mayuscula"....
 #210613  por ANTRAX
 26 Jul 2010, 19:42
Bueno, aca les traigo dos funciones... una verifica si el ean13 (de 13 digitos) es correcto el codigo de control (el ultimo caracter) y la otra funcion GENERA el correspondiente codigo de control de un EAN13 pasandole solamente los 12 digitos...

Espero que les sirva...
Código: [ Debe registrarse para ver este enlace ]
'========== Codigo realizado por CULD ==========
'============= [email protected] ===============
'La funcion "EAN13_Valido" devuelve si el codigo
'control del EAN13 es VALIDO...
'El algoritmo utilizado es el descrito en la
'siguiente pagina web
'http://latecladeescape.com/w0/recetas-algoritmicas/validar-codigos-ean.html
'La function "EAN13_Control" devuelve el numero de
'control correspondiente para un codigo EAN13 de
'12 digitos (asi devuelve el control que seria el 13)
'===============================================

Public Function EAN13_Valido(Codigo As String) As Boolean
'Variables a utilizar
Dim X As Integer
Dim SumaPar As Integer
Dim SumaImpar As Integer
Dim Resto As Integer
Dim Control As Integer

'Comprobar que el código tiene 13 dígitos. De no ser así, no es correcto.
If Len(Codigo) <> 13 Then
    EAN13_Valido = False
    Exit Function
End If

'Sumar los dígitos de lugares pares por un lado y los de los impares por otro, pero sin incuir el último dígito.
For X = 1 To 12
    If X Mod 2 = 0 Then
        SumaPar = SumaPar + CInt(Mid(Codigo, X, 1))
    Else
        SumaImpar = SumaImpar + CInt(Mid(Codigo, X, 1))
    End If
Next X

'multiplicar la suma de los pares por 3.
SumaPar = SumaPar * 3

'Sumar el resultado de los pares y el de los impares y hallar el resto de la división por 10.
Resto = (SumaPar + SumaImpar) Mod 10

'Realizar la operación 10 menos ese resto y ese es el dígito de control
Control = 10 - Resto

'Si como resultado sale 10, entenderemos que el dígito de control es 0.
If Control = 10 Then
    If CInt(Right(Codigo, 1)) = 0 Then
        EAN13_Valido = True
        Exit Function
    Else
        EAN13_Valido = False
        Exit Function
    End If
End If

'Comprobar que el dígito de control que hemos calculado y el último dígito del código EAN coinciden
If CInt(Right(Codigo, 1)) = Control Then
    EAN13_Valido = True
    Exit Function
Else
    EAN13_Valido = False
    Exit Function
End If
End Function

Public Function EAN13_Control(Codigo As String) As Integer
'Variables a utilizar
Dim X As Integer
Dim SumaPar As Integer
Dim SumaImpar As Integer
Dim Resto As Integer
Dim Control As Integer

'Comprobar que el código tiene 12 dígitos. De no ser así, no es correcto.
'devuelvo un numero mayor a 9
If Len(Codigo) <> 12 Then
    EAN13_Control = 10
    Exit Function
End If

'Sumar los dígitos de lugares pares por un lado y los de los impares por otro, pero sin incuir el último dígito.
For X = 1 To 12
    If X Mod 2 = 0 Then
        SumaPar = SumaPar + CInt(Mid(Codigo, X, 1))
    Else
        SumaImpar = SumaImpar + CInt(Mid(Codigo, X, 1))
    End If
Next X

'multiplicar la suma de los pares por 3.
SumaPar = SumaPar * 3

'Sumar el resultado de los pares y el de los impares y hallar el resto de la división por 10.
Resto = (SumaPar + SumaImpar) Mod 10

'Realizar la operación 10 menos ese resto y ese es el dígito de control
Control = 10 - Resto

'Si como resultado sale 10, entenderemos que el dígito de control es 0.
'de lo contrario, el control es el numero que salio
If Control = 10 Then
    EAN13_Control = 0
Else
    EAN13_Control = Control
End If
End Function
 #210617  por ANTRAX
 26 Jul 2010, 19:46
El siguiente codigo es para borrar desde vb6 los temporales de internet (ie), asi como el historial, las cookies, add-ons etc...
Sirve para internet 7 y 8 ......
Colocar en un boton lo siguiente:
Código: [ Debe registrarse para ver este enlace ]
Private Sub Command1_Click()
Shell "Rundll32.exe inetcpl.cpl, ClearMyTracksByProcess 4351", vbNormalFocus
End Sub
 #210987  por ANTRAX
 27 Jul 2010, 19:55
Ejemplo del método ExecWb para abrir el cuadro de diálogo " Guardar página web "

Ejemplo del método ExecWb del control webBrowser del visual basic para poder abrir el cuadro de diálogo Guardar como para guardar la página web cargada en el control.

Vista del cuadro de diálogo para guardar la pagina web

Aparte de este cuadro de diálogo, hay muchas otras opciones que se pueden realizar con este método, como por ejemplo la de copiar un texto y pegarlo, imprimir la página web cargada, seleccionar texto, copiar , cortar , ver el cuadro propiedades de página web, y muchas otras, solo hay que hecharle un ojo a las constantes que se le pasan al primer parámetro del método ExecWb.

Para probar el ejemplo que permite Abrir el Cuadro de Diálogo Guardar Página web como ... , colocar en un formulario un Command1 y también un control WebBrowser llamado WebBrowser 1.

Nota: el control WebBrowser se encuentra bajo el nombre de Microsoft Internet Controls desde el menú Proyecto - Componentes de vb.
Código: [ Debe registrarse para ver este enlace ]
Option Explicit

Private Sub Command1_Click()
'Abrimos el cuadro de diálogo abrir Como para el WebBrowser
WebBrowser1.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT, 0, 0
End Sub

Private Sub Form_Load()

Command1.Caption = " Guardar "

'Navegamos a una página de ejemplo mediante el método Navigate
MsgBox "Ejemplo que muestra como abrir el cuadro dialogo" & _
"guardar como para un control WEbBrowser", vbInformation

'Navegamos al cargar el formulario a la página de Google.
WebBrowser1.Navigate "www.google.com"

End Sub

Private Sub Form_Resize()

' esto es solo para redimensionar el control web
WebBrowser1.Move 0, 0, ScaleWidth, ScaleHeight - Command1.Height

'Posiciona el commandButton en el formulario
Command1.Top = WebBrowser1.Height
Command1.Left = ScaleWidth - Command1.Width

End Sub 
 #210989  por ANTRAX
 27 Jul 2010, 19:56
Ejemplo que utiliza la función del API SHBrowseForFolder y SHGetSpecialFolderLocation para selecionar uno de los ordenadores conectados a nuestra red.

Vista del cuadro de diálogo

Para desplegar el diálogo , llamar a la función " Buscar_Equipo_De_Red " y esta función luego retornará el nombre de la máquina seleccionada
Controles

Un CommandButton
Código: [ Debe registrarse para ver este enlace ]
Option Explicit

'Constantes
Private Const ERROR_SUCCESS As Long = 0
Private Const MAX_PATH As Long = 260
Private Const CSIDL_NETWORK As Long = &H12
Private Const BIF_RETURNONLYFSDIRS As Long = &H1
Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000

'Estructura BROWSEINFO necesaria para el Api SHBrowseForFolder

Private Type BROWSEINFO 'BI
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

'Declaramos la función Api SHBrowseForForlder
Private Declare Function SHBrowseForFolder _
Lib "shell32.dll" _
Alias "SHBrowseForFolderA" ( _
lpBrowseInfo As BROWSEINFO) As Long

'Declaramos la función Api SHGetSpecialFolderLocation

Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
ByVal hwndOwner As Long, _
ByVal nFolder As Long, _
pidl As Long) As Long


'Función que devuelve el nombre de la máquina


Private Function Buscar_Equipo_De_Red() As String

Dim BI As BROWSEINFO
Dim pidl As Long
Dim sPath As String
Dim pos As Integer

' Obtener el pidl de la carpeta Entorno de red
If SHGetSpecialFolderLocation(Me.hWnd, CSIDL_NETWORK, pidl) = ERROR_SUCCESS Then

With BI
.hOwner = Me.hWnd
.pidlRoot = pidl
.pszDisplayName = Space$(MAX_PATH)
.lpszTitle = " Seleccionar el ordenador de la red de la lista :"
.ulFlags = BIF_BROWSEFORCOMPUTER
End With

' Esto abre el diálogo para buscar el equipo de red
If SHBrowseForFolder(BI) <> 0 Then
'retorna el valor a la función, es decir el nombre del equipo
Buscar_Equipo_De_Red = "\\" & Replace(BI.pszDisplayName, Chr(0), vbNullString)
End If

End If
End Function

Private Sub Command1_Click()
' Llama a la función que abre el cuadro de diálogo
Call Buscar_Equipo_De_Red
End Sub

Private Sub Form_Load()
Command1.Caption = " Buscar equipo de Red "
End Sub 
 #210991  por ANTRAX
 27 Jul 2010, 19:58
Muestra de como utilizar la función del API SetLayeredWindowAttributes que permite aplicar transparencia a un formulario.

Este ejemplo tiene una función propia llamada Aplicar_Transparencia, donde se le pasa como parámetro el hwnd del formulario al que le queremos aplicar un grado para hacerlo transparente, y en el segundo parámetro se le pasa un valor de tipo Byte que indica el valor o grado de transparencia a aplicar.

Nota: La función Api SetLayeredWindowAttributes, se encuentra en plataformas Windows 2000 en adelante, por lo tanto no funcionará en plataformas anteriores, como Windows 98 o Windows ME
Código: [ Debe registrarse para ver este enlace ]
Option Explicit

'Declaración del Api SetLayeredWindowAttributes que establece _
la transparencia al form

Private Declare Function SetLayeredWindowAttributes Lib "user32" _
(ByVal hWnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As Long


'Recupera el estilo de la ventana
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long) As Long


'Declaración del Api SetWindowLong necesaria para aplicar un estilo _
al form antes de usar el Api SetLayeredWindowAttributes

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long


Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const WS_EX_LAYERED = &H80000
'Función para saber si formulario ya es transparente. _
Se le pasa el Hwnd del formulario en cuestión

Public Function Is_Transparent(ByVal hWnd As Long) As Boolean
On Error Resume Next

Dim Msg As Long

Msg = GetWindowLong(hWnd, GWL_EXSTYLE)

If (Msg And WS_EX_LAYERED) = WS_EX_LAYERED Then
Is_Transparent = True
Else
Is_Transparent = False
End If

If Err Then
Is_Transparent = False
End If

End Function

'Función que aplica la transparencia, se le pasa el hwnd del form y un valor de 0 a 255
Public Function Aplicar_Transparencia(ByVal hWnd As Long, _
Valor As Integer) As Long

Dim Msg As Long

On Error Resume Next

If Valor < 0 Or Valor > 255 Then
Aplicar_Transparencia = 1
Else
Msg = GetWindowLong(hWnd, GWL_EXSTYLE)
Msg = Msg Or WS_EX_LAYERED

SetWindowLong hWnd, GWL_EXSTYLE, Msg

'Establece la transparencia
SetLayeredWindowAttributes hWnd, 0, Valor, LWA_ALPHA

Aplicar_Transparencia = 0

End If


If Err Then
Aplicar_Transparencia = 2
End If

End Function 
  • 1
  • 5
  • 6
  • 7
  • 8
  • 9