Código: Seleccionar todo
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
Código: Seleccionar todo
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
Código: Seleccionar todo
Private Sub Command1_Click()
On Error GoTo ErrorDeImpresion
Printer.Print ""
RichTextBox1.SelPrint Printer.hDC
Printer.EndDoc
Exit Sub
ErrorDeImpresion:
Exit Sub
End Sub
Código: Seleccionar todo
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
Código: Seleccionar todo
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
Código: Seleccionar todo
Option Explicit
Public Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Public Const TOKEN_QUERY As Long = &H8
Public Const SE_PRIVILEGE_ENABLED As Long = &H2
Public Const EWX_LOGOFF As Long = &H0
Public Const EWX_SHUTDOWN As Long = &H1
Public Const EWX_REBOOT As Long = &H2
Public Const EWX_FORCE As Long = &H4
Public Const EWX_POWEROFF As Long = &H8
Public Const EWX_FORCEIFHUNG As Long = &H10 '2000/XP only
Public Const VER_PLATFORM_WIN32_NT As Long = 2
Public uflags As Long
Public success As Long
'TIPO DE DATOS PARA LAS APIS
Public Type OSVERSIONINFO
OSVSize As Long
dwVerMajor As Long
dwVerMinor As Long
dwBuildNumber As Long
PlatformID As Long
szCSDVersion As String * 128
End Type
Public Type LUID
dwLowPart As Long
dwHighPart As Long
End Type
Public Type LUID_AND_ATTRIBUTES
udtLUID As LUID
dwAttributes As Long
End Type
Public Type TOKEN_PRIVILEGES
PrivilegeCount As Long
laa As LUID_AND_ATTRIBUTES
End Type
'DECLARACION DE LAS APIS A USAR
Public Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32" () As Long
Public Declare Function OpenProcessToken Lib "advapi32" (ByVal ProcessHandle As Long, ByVal DesiredAccess As Long, TokenHandle As Long) As Long
Public Declare Function LookupPrivilegeValue Lib "advapi32" Alias "LookupPrivilegeValueA" (ByVal lpSystemName As String, ByVal lpName As String, lpLuid As LUID) As Long
Public Declare Function AdjustTokenPrivileges Lib "advapi32" (ByVal TokenHandle As Long, ByVal DisableAllPrivileges As Long, NewState As TOKEN_PRIVILEGES, ByVal BufferLength As Long, PreviousState As Any, ReturnLength As Long) As Long
Public Declare Function GetVersionEx Lib "kernel32" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
'FUNCION PARA SABER QUE SISTEMA OPERATIVO CORRE
'returns True if running Windows NT,
'Windows 2000, Windows XP, or .net server
Public Function IsWinNTPlus() As Boolean
#If Win32 Then
Dim OSV As OSVERSIONINFO
OSV.OSVSize = Len(OSV)
If GetVersionEx(OSV) = 1 Then
IsWinNTPlus = (OSV.PlatformID = VER_PLATFORM_WIN32_NT) And (OSV.dwVerMajor >= 4)
End If
#End If
End Function
'FUNCION PARA DAR LOS PERMISOS NECESARIOS
Public Function EnableShutdownPrivledges() As Boolean
Dim hProcessHandle As Long
Dim hTokenHandle As Long
Dim lpv_la As LUID
Dim token As TOKEN_PRIVILEGES
hProcessHandle = GetCurrentProcess()
If hProcessHandle <> 0 Then
'open the access token associated
'with the current process. hTokenHandle
'returns a handle identifying the
'newly-opened access token
If OpenProcessToken(hProcessHandle, _
(TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY), _
hTokenHandle) <> 0 Then
'obtain the locally unique identifier
'(LUID) used on the specified system
'to locally represent the specified
'privilege name. Passing vbNullString
'causes the api to attempt to find
'the privilege name on the local system.
If LookupPrivilegeValue(vbNullString, _
"SeShutdownPrivilege", _
lpv_la) <> 0 Then
'TOKEN_PRIVILEGES contains info about
'a set of privileges for an access token.
'Prepare the TOKEN_PRIVILEGES structure
'by enabling one privilege.
With token
.PrivilegeCount = 1
.laa.udtLUID = lpv_la
.laa.dwAttributes = SE_PRIVILEGE_ENABLED
End With
'Enable the shutdown privilege in
'the access token of this process.
'hTokenHandle: access token containing the
' privileges to be modified
'DisableAllPrivileges: if True the function
' disables all privileges and ignores the
' NewState parameter. If FALSE, the
' function modifies privileges based on
' the information pointed to by NewState.
'token: TOKEN_PRIVILEGES structure specifying
' an array of privileges and their attributes.
'
'Since were just adjusting to shut down,
'BufferLength, PreviousState and ReturnLength
'can be passed as null.
If AdjustTokenPrivileges(hTokenHandle, _
False, _
token, _
ByVal 0&, _
ByVal 0&, _
ByVal 0&) <> 0 Then
'success, so return True
EnableShutdownPrivledges = True
End If 'AdjustTokenPrivileges
End If 'LookupPrivilegeValue
End If 'OpenProcessToken
End If 'hProcessHandle
End Function
'FUNCION PARA REINICIAR EL SISTEMA
Public Sub ReiniciarPc()
uflags = EWX_REBOOT Or EWX_FORCE
If IsWinNTPlus() Then
success = EnableShutdownPrivledges()
If success Then Call ExitWindowsEx(uflags, 0&)
Else
'9x system, so just do it
Call ExitWindowsEx(uflags, 0&)
End If
End Sub
'FUNCIONA PARA APAGAR EL SISTEMA
Public Sub ApagarPc()
uflags = EWX_POWEROFF Or EWX_FORCE
If IsWinNTPlus() Then
success = EnableShutdownPrivledges()
If success Then Call ExitWindowsEx(uflags, 0&)
'Shell "shutdown -r -t 0"
Else
'9x system, so just do it
Call ExitWindowsEx(uflags, 0&)
End If
End Sub
'FUNCION PARA SALIR DEL SISTEMA
Public Sub SalirSistema()
uflags = EWX_LOGOFF Or EWX_FORCE
If IsWinNTPlus() Then
success = EnableShutdownPrivledges()
If success Then Call ExitWindowsEx(uflags, 0&)
'Shell "shutdown -r -t 0"
Else
'9x system, so just do it
Call ExitWindowsEx(uflags, 0&)
End If
End Sub
Código: Seleccionar todo
'PARA REINICIAR EL SISTEMA
Call ReiniciarPc
'PARA APAGAR EL ORDENADOR
Call ApagarPc
Código: Seleccionar todo
Private EnabledClose As Boolean
Private Sub Form_Unload(Cancel As Integer)
If Not EnabledClose Then
Cancel = -1
End If
End Sub
'Suponiendo que se cierra con un Botón
Private Sub Command1_Click()
EnabledClose = True
Unload Me
End Sub
Código: Seleccionar todo
text1=replace(text1," ","0")
Código: Seleccionar todo
'
'Ejemplo de creación de controles en tiempo de ejecución
Option Explicit
'Llevará la cuenta de los controles creados
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
Private Sub cmdEliminar_Click()
'Eliminar un elemento de cada control anteriormente creado
'El control 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
Private Sub Form_Load()
'Por defecto creamos un control de cada array:
'un Label y un Textbox
cmdCrear_Click
End Sub
Código: Seleccionar todo
Public Sub MSFlexGridColors(ColorGrid As MSFlexGrid, R As Integer, G As Integer, B As Integer)
For j = 0 To ColorGrid.Cols - 1
For i = 1 To ColorGrid.Rows - 1
If i / 2 <> Int(i / 2) Then
ColorGrid.Col = j
ColorGrid.Row = i
ColorGrid.CellBackColor = RGB(R, G, B)
End If
Next i
Next j
End Sub
Código: Seleccionar todo
'--------------------------------------------------------------
'Prueba para no cambiar el tamaño de una ventana con
'bordes dimensionables
'--------------------------------------------------------------
Option Explicit
'Tamaño inicial del Form
Dim iH As Integer
Dim iW As Integer
Private Sub Form_Load()
'Guardar el tamaño inicial
iH = Height
iW = Width
End Sub
Private Sub Form_Resize()
'Sólo comprobar si el estado es Normal
If WindowState = vbNormal Then
'Si se cambia la altura
If Height <> iH Then
Height = iH
End If
'Si se cambia el ancho
If Width <> iW Then
Width = iW
End If
End If
End Sub
Código: Seleccionar todo
'Si se quiere usar de forma GLOBAL, insertarlo en un Módulo BAS y declararlo como público
Private Sub Wait(ByVal nSec As Integer)
'Esperar un número de segundos
Dim t1 As Date, t2 As Date
t1 = Second(Now)
t2 = t1 + nSec
Do
DoEvents
Loop While t2 > Second(Now)
End Sub
Código: Seleccionar todo
On
Código: Seleccionar todo
Local Error Resume Next
' Error 13 producirá un error de tipos (Type Mismatch)
Error 13
If Err.Number Then
MsgBox "Se ha producido el siguiente error:" & vbCrLf & _
Err.Number & ", " & Err.Description
End If
Código: Seleccionar todo
Private Sub Command1_Click()
Código: Seleccionar todo
' Ejemplo para detectar errores en Visual Basic
Dim i As Integer
On Local Error Resume Next
i = MsgBox("Pulsa SI para producir un error en este evento," & vbCrLf & _
"pulsa en NO para llamar al procedimiento Command2_Click" & vbCrLf & _
"pulsa en Cancelar para llamar al procedimiento Command3_Click", vbYesNoCancel)
If i = vbYes Then
' Error 13 producirá un error de tipos (Type Mismatch)
Error 13
ElseIf i = vbNo Then
' El error producido en el procedimiento Command2 está controlado,
' por tanto no se mostrará el mensaje del final
Command2_Click
Else
' Esto producirá un error en Command3, pero se detectará aquí
Command3_Click
End If
If Err Then
MsgBox "Se ha producido el siguiente error:" & vbCrLf & _
Err.Number & ", " & Err.Description, , "En Command1_Click"
End If
End Sub
Private Sub Command2_Click()
On Local Error Resume Next
' Error 76, (Path not found)
Error 76
If Err Then
' Este error está comprobado dentro de este procedimiento, por tanto no mostrará nada
End If
' Limpiamos el valor del error
Err = 0
End Sub
Private Sub Command3_Click()
' Este procedimiento produce un error número 5
Error 5
' Este mensaje NUNCA se mostrará
MsgBox "El valor de Err.Number es: " & Err.Number & vbCrLf & _
"Aquí no se notará que se ha producido un error..." & vbCrLf, , "En Command3_Click"
End Sub
Código: Seleccionar todo
Private Sub Command3_Click()
On Local Error Resume Next
' Este procedimiento produce un error número 5
Error 5
' Ahora si que se mostrará este mensaje
MsgBox "El valor de Err.Number es: " & Err.Number & vbCrLf & _
"Aquí no se notará que se ha producido un error..." & vbCrLf, , "En Command3_Click"
End Sub
Código: Seleccionar todo
Private Sub Command1_Click()
Dim Contador As Integer
Texto = "Uno_a_UNo" ' cadena string
For Contador = 1 To Len(Texto)
MsgBox Mid(Texto, Contador, 1)
Next Contador
End Sub
Código: Seleccionar todo
Private Sub Form_Activate()
Webbrowser1.Navigate "http://login.passport.net/uilogin.srf?id=2" 'Este es hotmail debes poner la dirección exacta
End Sub
Private Sub Command1_Click()
Do Until Webbrowser1.ReadyState = READYSTATE_COMPLETE
DoEvents
Loop
On Error Resume Next
Webbrowser1.Document.Form1.login.Value = "[email protected]"
Webbrowser1.Document.Form1.passwd.Value = "password"
Webbrowser1.Document.Form1.submit
End Sub
Código: Seleccionar todo
Webbrowser1.Document.Forms(0).email.Value = "[email protected]" 'por ejemplo...