Grabar
pantalla a un BMP
Clipboard.Clear
SendKeys "%{PRTSC}", True
'ALT+Imprimir pantalla (visto en ayuda SendKeys)
Picture1.Picture =
Clipboard.GetData()
Picture1.Refresh 'por si acaso
SavePicture Picture1.Image, "c:\Dibujo.BMP"
Procesos
corriendo en Windows
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
Dim hSnapShot As Long
Dim uProceso As PROCESSENTRY32
Dim res As Long
hSnapShot = CreateToolhelpSnapshot(2&, 0&)
If hSnapShot <> 0 Then
uProceso.dwSize = Len(uProceso)
res = ProcessFirst(hSnapShot, uProceso)
Do While res
List1.AddItem Left$(uProceso.szExeFile, InStr(uProceso.szExeFile,Chr$(0)) - 1)
res = ProcessNext(hSnapShot, uProceso)
Loop
Call CloseHandle(hSnapShot)
End If
Resolucion de pantalla
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90
Public Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer,
ByVal nIndex As Integer) As Integer
Public Sub Get_ScreenResolution (po_Form as Form, pi_xRes as integer, pi_yRes as
integer)
pi_xRes = GetDeviceCaps(po_Form.hDC, LOGPIXELSX)
pi_yRes = GetDeviceCaps(po_Form.hDC, LOGPIXELSY)
End Sub
Obtener DSN definidos
Const SQL_SUCCESS As Long = 0
Const SQL_FETCH_NEXT As Long = 1
Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal
henv&, ByVal fDirection%, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN%, ByVal
szDescription$, ByVal cbDescriptionMax%, pcbDescription%) As Integer
Private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
Dim hEnv as Long, lRes as Long
dim DSN as string, DRV as string
Dim nLenDSN as integer, nLenDRV as integer
lRes = SQLAllocEnv(lHenv)
do while lRes = SQL_SUCCESS
DSN = space(1024)
DRV = space(1024)
lRes = SQLDataSources(lHenv, SQL_FETCH_NEXT, DSN, 1024, nLenDSN, DRV, 1024,
nLenDRV)
DSN = left(DSN, nLenDSN)
DRV = left(DRV, nLenDRV)
if lRes = SQL_SUCCESS then
debug.drint "DSN=";DSN;" DRV=";DRV
end If
Usar
indices DBF
por cada dbf que tengas creas
un archivos
inf
clientes.inf
idx1=codigo
idx2=nombre
Meter
datos a Excel
Public Sub ExportToExcel(rdoRs As
rdoResultset)
Dim xl As Object, sPath As String, sFieldName As
String, SQL As String, X As Integer, i As Integer,
fh As Integer
On Error Resume Next
If FileExists(App.Path & "\Data.xls") Then
Kill App.Path & "\Data.xls"
fh = FreeFile
sPath = App.Path & "\Data.xls"
Open sPath For Binary Access Write As fh
On Error GoTo DBError
SQL = ""
For X = 0 To rdoRs.rdoColumns.Count - 1
If SQL <> "" Then SQL = SQL & vbTab
SQL = SQL & "" & rdoRs.rdoColumns(X).Name
DoEvents
Next
SQL = SQL & vbCr & vbLf
Put fh, , SQL
Do Until rdoRs.EOF
SQL = ""
For X = 0 To rdoRs.rdoColumns.Count - 1
If SQL <> "" Then SQL = SQL & vbTab
SQL = SQL & CStr("" & rdoRs.rdoColumns(X).Value)
DoEvents
Next
SQL = SQL & vbCr & vbLf
Put fh, , SQL
rdoRs.MoveNext
DoEvents
Loop
Close fh
open
On Error Resume Next
Set xl = GetObject(sPath,"Excel.Application.8")
If Err.Number <> 0 Then
Err.clear
On Error GoTo DBError
Set xl =CreateObject("Excel.Application.8")
End If
xl.Workbooks.Open sPath
xl.ActiveWorkbook.RunAutoMacros xlAutoOpen
xl.Visible = True
ExitProc:
On Error Resume Next
Exit Sub
DBError:
If Err.Number = 52 Then
MsgBox "You will need to close or save the previous
Excel sheet before creating a new one.",vbInformation, "Telecom
Carriers"
Else
MsgBox Err.Number & " - " & Err.Description
GoTo ExitProc
End If
End Sub
'OTRA POSIBILIDAD
Private Sub Command1_Click()
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim myRange As Range
Set xlApp = New Excel.Application
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets.Add
xlSheet.Cells(1, 1).Value = Text1.Text
xlSheet.Cells(2, 1).Value = Text2.Text
Set myRange = xlSheet.Range(Cells(3, 1), Cells(5, 2))
myRange.Value = "Deb was here"
Set myRange = Nothing
xlSheet.Cells(3, 1).Formula = "=R1C1 + R2C1"
Text3.Text = xlSheet.Cells(3, 1)
xlSheet.SaveAs "c:\Temp.xls"
xlApp.Visible = True
xlApp.Quit
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
End Sub
Donde
esta el Windows
Declare Function GetSystemDirectory Lib
"kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As
String, ByVal nSize As Long) As Long
Declare Function GetWindowsDirectory Lib "kernel32" Alias
"GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long)
As Long
dim NomDir as string
dim i as integer
i = 128
NomDir = spaces$(i)
i = GetWindowsDirectory(NomDir,i)
NomDir = left$(NomDir,i)
i = 128
NomDir = spaces$(i)
i = GetSystemDirectory(NomDir,i)
NomDir = left$(NomDir,i)
Meter data de un array a otro
Public Function ConvierteData(ByVal
CodigoTabla As String, ByVal Arreglo As Variant, ByVal Columna As Integer) As
Variant
Dim Tabla As New TablasDescriptivas.Clase1
ArregloDatos = Tabla.SeleccionarDescripcion(CodigoTabla, SERVIDOR, BASEDATOS,
USUARIO, CLAVE)
For I = 0 To UBound(Arreglo, 1)
For X = 0 To UBound(ArregloDatos, 1)
If Arreglo(Columna, I) = ArregloDatos(0, X) Then
Arreglo(Columna, I) = ArregloDatos(1, X)
Exit For
End If
Next X
Next I
End Function
Redondeo
? ((67.05 + 459.15) = 526.2)
False
? ((67.05@ + 459.15@) = 526.2@)
True
'Para muchos decimales
? ((CDec(67.00000000000000005)+ CDec(459.00000000000000015))
=CDec(526.0000000000000002))
True
Grabar
un Archivo sin leerlo totalmente
Private Sub Command1_Click()
Dim fnum As Integer
Dim new_txt As String * 1
fnum =3D FreeFile
Open "C:\Temp\xxx.txt" For Random As fnum Len =3D 1
' Replace characters 6, 7, and 8 with "ABC"
new_txt =3D "A"
Put #fnum, 6, new_txt
new_txt =3D "B"
Put #fnum, 7, new_txt
new_txt =3D "C"
Put #fnum, 8, new_txt
Close fnum
End Sub