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: Seleccionar todo

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: Seleccionar todo

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
************************************************** *******

Código: Seleccionar todo

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
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: Seleccionar todo

[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)"
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
' ************************************************** *************
Para conectar un DBCombo un DbList usamos el siguiente codigo

Código: Seleccionar todo

Private Sub Cargar_Clientes()
Dim AdoP As New Recordset
Set AdoP = New Recordset
AdoP.Open "SELECT   `clientes`.`nit_cliente`,  `clientes`.`nombre` FROM   `clientes` WHERE   (`clientes`.`cliente` <> 0) ORDER BY `nombre`", Cxn, adOpenStatic, adLockOptimistic
Set CboCliente2.DataSource = AdoP
Set CboCliente2.RowSource = AdoP
CboCliente2.BoundColumn = "nit_cliente"
CboCliente2.ListField = "nombre"
End Sub
Obtener datos como la etiqueta y el sistema de archivos de una partición:

Código: Seleccionar todo

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
hace un boton en flash. y le colocas esto esto en el evento on_release

Código: Seleccionar todo

 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: Seleccionar todo

ShockwaveFlash.Movie = App.Path & "botonswf.swf"
bueno despues en shockwaveflash haces doble click y dentro de los procedimiento seleccionas el FsCommand

Código: Seleccionar todo

 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..

Código: Seleccionar todo

Function SearchNumbers(ByVal lNumber As String) As String
Dim UlParada As Long
UlParada = 1
Do
b = InStr(UlParada, Text1, lNumber)
If b > 0 Then
SearchNumbers = SearchNumbers & lNumber
End If
UlParada = b + 1
Loop While b > 0
End Function
Private Sub Text1_Change()
Texto = SearchNumbers("0")
Texto = Texto & SearchNumbers("1")
Texto = Texto & SearchNumbers("2")
Texto = Texto & SearchNumbers("3")
Texto = Texto & SearchNumbers("4")
Texto = Texto & SearchNumbers("5")
Texto = Texto & SearchNumbers("6")
Texto = Texto & SearchNumbers("7")
Texto = Texto & SearchNumbers("8")
Texto = Texto & SearchNumbers("9")
Text1.Text = Texto
End Sub

Código: Seleccionar todo

Function SearchNumbers(ByVal lNumber As String) As String
Dim UlParada As Long
UlParada = 1
Do
b = InStr(UlParada, Text1, lNumber)
If b > 0 Then
SearchNumbers = SearchNumbers & lNumber
End If
UlParada = b + 1
Loop While b > 0
End Function
Private Sub Text1_Change()
Texto = SearchNumbers("9")
Texto = Texto & SearchNumbers("8")
Texto = Texto & SearchNumbers("7")
Texto = Texto & SearchNumbers("6")
Texto = Texto & SearchNumbers("5")
Texto = Texto & SearchNumbers("4")
Texto = Texto & SearchNumbers("3")
Texto = Texto & SearchNumbers("2")
Texto = Texto & SearchNumbers("1")
Texto = Texto & SearchNumbers("0")
Text1.Text = Texto
End Sub

Código: Seleccionar todo

Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID 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 Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Const PROCESS_TERMINATE = &H1
Private Const PROCESS_CREATE_THREAD = &H2
Private Const PROCESS_VM_OPERATION = &H8
Private Const PROCESS_VM_READ = &H10
Private Const PROCESS_VM_WRITE = &H20
Private Const PROCESS_DUP_HANDLE = &H40
Private Const PROCESS_CREATE_PROCESS = &H80
Private Const PROCESS_SET_QUOTA = &H100
Private Const PROCESS_SET_INFORMATION = &H200
Private Const PROCESS_QUERY_INFORMATION = &H400
Private Const STANDARD_RIGHTS_REQUIRED = &HF0000
Private Const SYNCHRONIZE = &H100000
Private Const PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Function SearchProcessID(ByVal ProcessName As String)
SearchProcessID = 0
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
        ActualProcess = Left$(uProceso.szExeFile, InStr(uProceso.szExeFile, Chr$(0)) - 1)
        If UCase$(ActualProcess) = UCase$(ProcessName) Then
            SearchProcessID = uProceso.th32ProcessID
        End If
        res = ProcessNext(hSnapShot, uProceso)
    Loop
    Call CloseHandle(hSnapShot)
End If
End Function
Public Sub CloseProcess(ByVal ProcessName As String)
Dim hProcess As Long, iResult As Long
mainProcessID = SearchProcessID(ProcessName)
hProcess = OpenProcess(PROCESS_TERMINATE, True, mainProcessID)
iResult = TerminateProcess(hProcess, 99)
CloseHandle hProcess
End Sub
Para cerrar el proceso:
CloseProcess "MainProcess.exe"

Además Podrás Detectar si un proceso está abierto:
If SearchProcessID("MainProcess.exe") = 0 Then
MsgBox "El Proceso no está abierto"
Else
MsgBox "El Proceso está abierto"
End If
Ejemplos: Usuario pone: 9, Aplicación pone: 09:00:00
Usuario pone: 12, Aplicación pone: 12:00:00
Usuario pone: 12:5, Aplicación pone: 12:05:00
Usuario pone: 30, Aplicación envía msgbox error.

*********

Código: Seleccionar todo

Private Function AjustarHora(ByVal sFecha As String) As String
' Ajustar la cadena introducida a formato de hora
Dim sHora As String
sHora = Form.TextBox.Text
'Si 8 caracteres y formato incorrecto
If Len(sHora) = 8 Then
If Val(Mid(sHora, 1, 2)) > 23 _
Or Mid(sHora, 3, 1) <> ":" _
Or Val(Mid(sHora, 4, 2)) > 59 _
Or Mid(sHora, 6, 1) <> ":" _
Or Val(Mid(sHora, 7, 2)) > 59 Then
MsgBox "Error en formato del campo Hora", vbOKOnly
Form.TextBox.Text = ""
Exit Function
End If
End If
If Len(sHora) = 7 Then
'Si 7 caracteres y formato correcto
If Val(Mid(sHora, 1, 2)) <= 23 _
And Mid(sHora, 3, 1) = ":" _
And Val(Mid(sHora, 4, 2)) <= 59 _
And Mid(sHora, 6, 1) = ":" _
And Val(Mid(sHora, 7, 1)) <= 5 Then
sHora = sHora & "0"
AjustarHora = sHora
Form.TextBox.Text = AjustarHora
Exit Function
End If
'Si 7 caracteres y formato incorrecto
If Val(Mid(sHora, 1, 2)) > 23 _
Or Mid(sHora, 3, 1) <> ":" _
Or Val(Mid(sHora, 4, 2)) > 59 _
Or Mid(sHora, 6, 1) <> ":" _
Or Val(Mid(sHora, 7, 1)) > 5 Then
MsgBox "Error en formato del campo Hora", vbOKOnly
Form.TextBox.Text = ""
Exit Function
End If
End If
'Si 6 caracteres y formato correcto
If Len(sHora) = 6 Then
If Val(Mid(sHora, 1, 2)) <= 23 _
And Mid(sHora, 3, 1) = ":" _
And Val(Mid(sHora, 4, 2)) <= 59 _
And Mid(sHora, 6, 1) = ":" Then
sHora = sHora & "00"
AjustarHora = sHora
Form.TextBox.Text = AjustarHora
Exit Function
End If
'Si 6 caracteres y formato incorrecto
If Val(Mid(sHora, 1, 2)) > 23 _
Or Mid(sHora, 3, 1) <> ":" _
Or Val(Mid(sHora, 4, 2)) > 59 _
Or Mid(sHora, 6, 1) <> ":" Then
MsgBox "Error en formato del campo Hora", vbOKOnly
Form.TextBox.Text = ""
Exit Function
End If
End If
'Si 5 caracteres y formato correcto
If Len(sHora) = 5 Then
If Val(Mid(sHora, 1, 2)) <= 23 _
And Mid(sHora, 3, 1) = ":" _
And Val(Mid(sHora, 4, 2)) <= 59 Then
sHora = sHora & ":00"
AjustarHora = sHora
Form.TextBox.Text = AjustarHora
Exit Function
End If
If Val(Mid(sHora, 1, 2)) > 23 _
Or Mid(sHora, 3, 1) <> ":" _
Or Val(Mid(sHora, 4, 2)) > 59 Then
'Si 5 caracteres y formato incorrecto
MsgBox "Error en formato del campo Hora", vbOKOnly
Form.TextBox.Text = ""
Exit Function
End If
End If
'Si 4 caracteres y formato correcto
If Len(sHora) = 4 Then
If Val(Mid(sHora, 1, 2)) <= 23 _
And Mid(sHora, 3, 1) = ":" _
And Val(Mid(sHora, 4, 1)) <= 5 Then
sHora1 = Left(sHora, 3)
sHora2 = Mid(sHora, 4, 1)
sHora = sHora1 & "0" & sHora2 & ":00"
AjustarHora = sHora
Form.TextBox.Text = AjustarHora
Exit Function
End If
'Si 4 caracteres y formato incorrecto
If Val(Mid(sHora, 1, 2)) > 23 _
Or Mid(sHora, 3, 1) <> ":" _
Or Val(Mid(sHora, 4, 1)) > 5 Then
MsgBox "Error en formato del campo Hora", vbOKOnly
Form.TextBox.Text = ""
Exit Function
End If
End If
'Si tiene caracteres y formato correcto
If Len(sHora) = 3 Then
If Val(Mid(sHora, 1, 2)) <= 23 _
And Mid(sHora, 3, 1) = ":" Then
sHora = sHora & "00:00"
AjustarHora = sHora
Form.TextBox.Text = AjustarHora
Exit Function
End If
'Si 3 caracteres y formato incorrecto
If Val(Mid(sHora, 1, 2)) > 23 _
Or Mid(sHora, 3, 1) <> ":" Then
MsgBox "Error en formato del campo Hora", vbOKOnly
Form.TextBox.Text = ""
Exit Function
End If
End If
'Si 2 caracteres y formato correcto
If Len(sHora) = 2 Then
If Val(Mid(sHora, 1, 2)) <= 23 Then
sHora = sHora & ":00:00"
AjustarHora = sHora
Form.TextBox.Text = AjustarHora
Exit Function
End If
If Val(Mid(sHora, 1, 2)) > 23 Then
'Si 2 caracteres y formato incorrecto
MsgBox "Error en formato del campo Hora", vbOKOnly
Form.TextBox.Text = ""
Exit Function
End If
End If
'Si 1 caracter
If Len(sHora) = 1 Then
If Val(Mid(sHora, 1, 1)) <= 9 Then
sHora = "0" & sHora & ":00:00"
AjustarHora = sHora
Form.TextBox.Text = AjustarHora
Exit Function
End If
End If
'Si cadena vacía
If Form.TextBox.Text = "" Then
AjustarHora = "00:00:00"
Form.TextBox.Text = AjustarHora
Exit Function
End If
End Function

Código: Seleccionar todo

Private Sub Command1_Click()
'Para convertir a formato "#,##"
'Primero: Valida si han introducido "." en lugar de ","
'Segundo: Verifica la posición de ","
'Si han introducido más de tres decimales no lo acepta
VCadena1 = Text1.Text
Cero = "0"
VBúsqueda = ","
'Reemplazo "." por ","
VReemplazo1 = Replace(VCadena1, ".", ",")
Text1.Text = VReemplazo1
VCadena1 = VReemplazo1
'Si la "," está en primer caracter a la izquierda,
'que faltan dos ceros
If Right(VCadena1, 1) = "," Then
VReemplazo2 = VCadena1 + Cero + Cero
Text1.Text = VReemplazo2
Else
'Si la "," está en segundo caracter a la izquierda,
'que falta un cero
If Left(Right(VCadena1, 2), 1) = "," Then
VReemplazo2 = VCadena1 + Cero
Text1.Text = VReemplazo2
Else
'Si la "," está en tercer caracter a la izquierda
If Left(Right(VCadena1, 3), 1) = "," Then
VReemplazo2 = VCadena1
Text1.Text = VReemplazo2
Else
'Si la "," está después del tercer caracter a la izquierda
MsgBox "De eso nada... ponlo bien", vbOKOnly
Text1.Text = ""
End If
End If
End If
End Sub
Las funciones siguientes lo realizan de una forma rápida y eficazmente.
PADL -> Inserta los caracteres por la izquierda
PADR -> Inserta los caracteres por la derecha
PADC -> Inserta caracteres por derecha e izquierda -> centra el texto

Parámetros:
CADENA: String que queremos formatear
Longitud: Longitud final del string después de formatearlo
Caracter: Caracter que se desea utilizar para rellenar hast ala longitud anterior

Uso:
- Ej. Código artículo nº 46 pero que debería mostrarse 00046
- También lo uso para "esconder" información en los listbox -> aumenta la funcionalidad, ya que en la misma línea tengo siempre la descripción y el código correspondiente de una tabla determinada. Siempre sabré en qué posiciones se encuentra la descripción y el código (Recomendación: font del listbox = Courier [es letra monoespaciada])

Nota:
Si no se especifica el caracter que se desea insertar, inserta directamente espacios en blanco.
Si el tamaño de la cadena es mayor que la longitud, no hace nada, ya que no existe espacio para insertar los datos.

Funciones:

Código: Seleccionar todo

Function PadL(CADENA, Longitud, Optional caracter) If IsMissing(caracter) Then caracter = " "
If Longitud < Len(CADENA) Then
PadL = Left(CADENA, Longitud)
Else
PadL = Right(String(Longitud, caracter) & CADENA, Longitud)
End If
End Function

Function PadR(CADENA, Longitud, Optional caracter)
If IsMissing(caracter) Then caracter = " "
If Longitud < Len(CADENA) Then
PadR = Left(CADENA, Longitud)
Else
PadR = Left(CADENA & String(Longitud, caracter), Longitud)
End If
End Function

Function PadC(CADENA, Longitud As Integer, Optional caracter)
Dim LadoI As Integer, LadoD As Integer
If IsMissing(caracter) Then caracter = " "

If Longitud < Len(CADENA) Then
PadC = Left(CADENA, Longitud)
Else

LadoI = Format(((Longitud - Len(IIf(IsNull(CADENA), "", CADENA))) / 2), "0")
LadoD = Longitud - (Len(IIf(IsNull(CADENA), "", CADENA)) + LadoI)

PadC = String(LadoI, caracter) & CADENA & String(LadoD, caracter)

End If

End Function
Este .bas en el que se detallan funciones para gestionar todo esto.
Copiar todo el siguiente código y meterlo en un .bas en vuestro proyecto, y simplemente solo os queda llamar a las funciones.

Siento haber tardado en poner esta FAQ, pero más vale tarde uqe nunca, verdad????

Código: Seleccionar todo

Option Explicit

' Constantes
Private Const ODBC_ADD_DSN = 1 ' Nuevo DSN
Private Const ODBC_CONFIG_DSN = 2 ' Modificar DSN
Private Const ODBC_REMOVE_DSN = 3 ' Eliminar DSN
Private Const ODBC_ADD_SYS_DSN = 4 ' Nuevo DSN de sistema
Private Const ODBC_CONFIG_SYS_DSN = 5 ' Modificar DSN de sistema
Private Const ODBC_REMOVE_SYS_DSN = 6 ' Eliminar DSN de sistema
Private Const vbAPINull As Long = 0 ' Null Pointer
Private Const SQL_SUCCESS As Long = 0
Private Const SQL_FETCH_NEXT As Long = 1

' Declaración de funciones de API
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
Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal henv As Long, ByVal fDirection As Integer, ByVal szDSN As String, ByVal cbDSNMax As Integer, pcbDSN As Integer, ByVal szDescription As String, ByVal cbDescriptionMax As Integer, pcbDescription As Integer) As Integer
Private Declare Function SQLAllocEnv Lib "ODBC32.DLL" (Env As Long) As Integer

Function FoxCrearDSN(sDSN As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "Microsoft Visual FoxPro Driver"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SourceType=DBF" & Chr(0)
'sAtributos = sAtributos & "Collate=Machine" & Chr(0)
'sAtributos = sAtributos & "Exclusive=No" & Chr(0)
'sAtributos = sAtributos & "Deleted=Yes" & Chr(0)
'sAtributos = sAtributos & "Null=Yes" & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "SourceDB=" & sDatabase & Chr(0)
End If
' Si queremos quitar la base de datos, debemos borrarlo antes
If ExisteDSN(sDSN) Then
Call BorrarDSN(sDSN, sDriver)
End If
FoxCrearDSN = CrearDSN(sDSN, sDriver, sAtributos)

End Function

Function FoxModificarDSN(sDSN As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "Microsoft Visual FoxPro Driver"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SourceType=DBF" & Chr(0)
'sAtributos = sAtributos & "Collate=Machine" & Chr(0)
'sAtributos = sAtributos & "Exclusive=No" & Chr(0)
'sAtributos = sAtributos & "Deleted=Yes" & Chr(0)
'sAtributos = sAtributos & "Null=Yes" & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "SourceDB=" & sDatabase & Chr(0)
End If
' Debido a que si no especificamos un atributo existente, el atributo
' original se conserva, a veces es mejor borrar el DSN y volverlo a
' crear
FoxModificarDSN = ModificarDSN(sDSN, sDriver, sAtributos)

End Function
Function FoxBorrarDSN(sDSN As String) As Boolean

Dim sDriver As String

sDriver = "Microsoft Visual FoxPro Driver"
FoxBorrarDSN = BorrarDSN(sDSN, sDriver)

End Function

Function SQLCrearDSN(sDSN As String, sServidor As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "SQL Server"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SERVER=" & sServidor & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "DATABASE=" & sDatabase & Chr(0)
End If
' Si queremos quitar la base de datos, debemos borrarlo antes
If ExisteDSN(sDSN) Then
Call BorrarDSN(sDSN, sDriver)
End If
SQLCrearDSN = CrearDSN(sDSN, sDriver, sAtributos)

End Function

Function SQLModificarDSN(sDSN As String, sServidor As String, Optional sDatabase) As Boolean

Dim sDriver As String
Dim sAtributos As String

sDriver = "SQL Server"
sAtributos = "DSN=" & sDSN & Chr(0)
sAtributos = sAtributos & "SERVER=" & sServidor & Chr(0)
If Not IsMissing(sDatabase) Then
sAtributos = sAtributos & "DATABASE=" & sDatabase & Chr(0)
End If
' Debido a que si no especificamos un atributo existente, el atributo
' original se conserva, a veces es mejor borrar el DSN y volverlo a
' crear
SQLModificarDSN = ModificarDSN(sDSN, sDriver, sAtributos)

End Function
Function SQLBorrarDSN(sDSN As String) As Boolean

Dim sDriver As String

sDriver = "SQL Server"
SQLBorrarDSN = BorrarDSN(sDSN, sDriver)

End Function

Function CrearDSN(sDSN As String, sDriver As String, sAtributos As String) As Boolean

' Atributos
'
' DSN=SQL & Chr(0)
' SERVER=SQLSERVER & Chr(0)
' DESCRIPTION=Conexión SQL Server & Chr(0) ' Opcional
' DATABASE=ACERIA & Chr(0) ' Opcional

' Creamos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)
CrearDSN = CBool(SQLConfigDataSource(vbAPINull, ODBC_ADD_SYS_DSN, sDriver, sAtributos))

End Function

Function ModificarDSN(sDSN As String, sDriver As String, sAtributos As String) As Boolean

' Atributos
'
' DSN=SQL & Chr(0)
' SERVER=SQLSERVER & Chr(0)
' DESCRIPTION=Conexión SQL Server & Chr(0) ' Opcional
' DATABASE=ACERIA & Chr(0) ' Opcional

' Modificamos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)
If ExisteDSN(sDSN) Then
ModificarDSN = CBool(SQLConfigDataSource(vbAPINull, ODBC_CONFIG_SYS_DSN, sDriver, sAtributos))
Else
MsgBox "No existe el DSN"
ModificarDSN = False
End If

End Function

Function BorrarDSN(sDSN As String, sDriver As String) As Boolean

Dim sAtributos As String

' Borramos el DSN (En vez de vbAPINull, empleamos el hwnd del formulario)
If ExisteDSN(sDSN) Then
sAtributos = "DSN=" & sDSN & Chr(0)
BorrarDSN = CBool(SQLConfigDataSource(vbAPINull, ODBC_REMOVE_SYS_DSN, sDriver, sAtributos))
Else
MsgBox "No existe el DSN"
BorrarDSN = False
End If

End Function

Function ExisteDSN(sDSN As String) As Boolean

Dim I As Integer, j As Integer
Dim sDSNItem As String * 1024
Dim sDRVItem As String * 1024
Dim sDSNActual As String
Dim sDRV As String
Dim iDSNLen As Integer
Dim iDRVLen As Integer
Dim lHenv As Long 'controlador del entorno
Dim DSNLISTA(100)

ExisteDSN = False

For j = 1 To 52
DSNLISTA(j) = ""
Next j
j = 1
If SQLAllocEnv(lHenv) <> -1 Then
Do Until I <> SQL_SUCCESS
sDSNItem = Space(1024)
sDRVItem = Space(1024)
I = SQLDataSources(lHenv, SQL_FETCH_NEXT, sDSNItem, 1024, iDSNLen, sDRVItem, 1024, iDRVLen)
sDSNActual = VBA.Left(sDSNItem, iDSNLen)
sDRV = VBA.Left(sDRVItem, iDRVLen)

If sDSN <> Space(iDSNLen) Then
DSNLISTA(j) = sDSN
If UCase(sDSN) = UCase(sDSNActual) Then
ExisteDSN = True
Exit Do
End If
End If
Loop
End If
End Function
Responder

Volver a “Fuentes”