Private Sub bStart_Click(sender As Object, e As EventArgs) Handles bStart.Click
Dim psList() As Process
Try
psList = Process.GetProcesses()
For Each p As Process In psList
Console.WriteLine(p.Id.ToString() + " " + p.ProcessName.ToString)
Next p
Catch ex As Exception
Console.WriteLine(ex.Message)
End Try
End Sub
martes, 21 de febrero de 2017
Clase Visual Basic .NET para grabar / leer un archivo de configuración o settings en XML (clave - valor)
Public Class clsSettings
'http://www.tek-tips.com/faqs.cfm?fid=6320
'ejemplo uso:
'clsSettings.clsSetSetting("MyValue", "1234567890")
'msgbox(clsSettings.GetSetting("MyValue"))
'NOTA: Si queremos guardar un archivo de configuración diferente para cada usuario,
'solo tenemos que cambiar Application.StartupPath por Application.LocalUserAppDataPath
Public Shared Function GetSetting(ByVal Key As String) As String
Dim sReturn As String = String.Empty
Dim dsSettings As New DataSet
If System.IO.File.Exists(Application.StartupPath & "\Settings.xml") Then
dsSettings.ReadXml(Application.StartupPath & "\Settings.xml")
Else
dsSettings.Tables.Add("Settings")
dsSettings.Tables(0).Columns.Add("Key", GetType(String))
dsSettings.Tables(0).Columns.Add("Value", GetType(String))
End If
Dim dr() As DataRow = dsSettings.Tables("Settings").Select("Key = '" & Key & "'")
If dr.Length = 1 Then sReturn = dr(0)("Value").ToString
Return sReturn
End Function
Public Shared Sub SetSetting(ByVal Key As String, ByVal Value As String)
Dim dsSettings As New DataSet
If System.IO.File.Exists(Application.StartupPath & "\Settings.xml") Then
dsSettings.ReadXml(Application.StartupPath & "\Settings.xml")
Else
dsSettings.Tables.Add("Settings")
dsSettings.Tables(0).Columns.Add("Key", GetType(String))
dsSettings.Tables(0).Columns.Add("Value", GetType(String))
End If
Dim dr() As DataRow = dsSettings.Tables(0).Select("Key = '" & Key & "'")
If dr.Length = 1 Then
dr(0)("Value") = Value
Else
Dim drSetting As DataRow = dsSettings.Tables("Settings").NewRow
drSetting("Key") = Key
drSetting("Value") = Value
dsSettings.Tables("Settings").Rows.Add(drSetting)
End If
dsSettings.WriteXml(Application.StartupPath & "\Settings.xml")
End Sub
End Class
'http://www.tek-tips.com/faqs.cfm?fid=6320
'ejemplo uso:
'clsSettings.clsSetSetting("MyValue", "1234567890")
'msgbox(clsSettings.GetSetting("MyValue"))
'NOTA: Si queremos guardar un archivo de configuración diferente para cada usuario,
'solo tenemos que cambiar Application.StartupPath por Application.LocalUserAppDataPath
Public Shared Function GetSetting(ByVal Key As String) As String
Dim sReturn As String = String.Empty
Dim dsSettings As New DataSet
If System.IO.File.Exists(Application.StartupPath & "\Settings.xml") Then
dsSettings.ReadXml(Application.StartupPath & "\Settings.xml")
Else
dsSettings.Tables.Add("Settings")
dsSettings.Tables(0).Columns.Add("Key", GetType(String))
dsSettings.Tables(0).Columns.Add("Value", GetType(String))
End If
Dim dr() As DataRow = dsSettings.Tables("Settings").Select("Key = '" & Key & "'")
If dr.Length = 1 Then sReturn = dr(0)("Value").ToString
Return sReturn
End Function
Public Shared Sub SetSetting(ByVal Key As String, ByVal Value As String)
Dim dsSettings As New DataSet
If System.IO.File.Exists(Application.StartupPath & "\Settings.xml") Then
dsSettings.ReadXml(Application.StartupPath & "\Settings.xml")
Else
dsSettings.Tables.Add("Settings")
dsSettings.Tables(0).Columns.Add("Key", GetType(String))
dsSettings.Tables(0).Columns.Add("Value", GetType(String))
End If
Dim dr() As DataRow = dsSettings.Tables(0).Select("Key = '" & Key & "'")
If dr.Length = 1 Then
dr(0)("Value") = Value
Else
Dim drSetting As DataRow = dsSettings.Tables("Settings").NewRow
drSetting("Key") = Key
drSetting("Value") = Value
dsSettings.Tables("Settings").Rows.Add(drSetting)
End If
dsSettings.WriteXml(Application.StartupPath & "\Settings.xml")
End Sub
End Class
Clase Visual Basic .NET para enviar correo con GMAIL. Este código también es válido para otros servidores de correo haciendo pequeños cambios.
Imports System.Net.Mail
'using a google account to send email if you got authentication error, you need to enable Allowing less secure apps or Sign in using App Passwords.
'https://www.youtube.com/watch?v=MOnyExcIPVY'
'
'NOTA: Aún habiendo activado el uso de aplicaciones de terceros para enviar a través del servidor de Gmail, Google también puede bloquear los envíos si el dispositivo no es de confianza. Aconsejo a identificarse en Gmail via web en el dispositivo que usará la aplicación para que sea reconocido como dispositivo de confianza.
Public Class clsMailSender
Const GMAILUSER = "your_account@gmail.com"
Const GMAILPASS = "your_password"
Const GMAILSMTPHOST = "smtp.gmail.com"
Const GMAILSMTPPORT = 587
Const GMAILbEnableSSL = True
'Si no funciona por el puerto SMTP 587, prueba con el 25
Public Function SendEmailGMAIL(ByVal MailSubject As String, ByVal MessageBody As String, ByVal ToAddresses As String) As Boolean
'SendEmailGMAIL("subject","messagebody","address1;address2;...")
Try
Dim Mail As New MailMessage()
Mail.Subject = MailSubject
Mail.From = New System.Net.Mail.MailAddress(GMAILUSER)
For Each Address As String In Split(ToAddresses, ";")
Mail.To.Add(Address)
Next
Mail.Body = MessageBody
Dim SmtpServer As New SmtpClient()
SmtpServer.Credentials = New Net.NetworkCredential(GMAILUSER, GMAILPASS)
SmtpServer.Host = GMAILSMTPHOST
SmtpServer.Port = GMAILSMTPPORT
SmtpServer.EnableSsl = GMAILbEnableSSL
SmtpServer.Send(Mail)
Return True
Catch ex As Exception
Console.WriteLine(ex.Message)
Return False
End Try
End Function
End Class
'using a google account to send email if you got authentication error, you need to enable Allowing less secure apps or Sign in using App Passwords.
'https://www.youtube.com/watch?v=MOnyExcIPVY'
'
'NOTA: Aún habiendo activado el uso de aplicaciones de terceros para enviar a través del servidor de Gmail, Google también puede bloquear los envíos si el dispositivo no es de confianza. Aconsejo a identificarse en Gmail via web en el dispositivo que usará la aplicación para que sea reconocido como dispositivo de confianza.
Public Class clsMailSender
Const GMAILUSER = "your_account@gmail.com"
Const GMAILPASS = "your_password"
Const GMAILSMTPHOST = "smtp.gmail.com"
Const GMAILSMTPPORT = 587
Const GMAILbEnableSSL = True
'Si no funciona por el puerto SMTP 587, prueba con el 25
Public Function SendEmailGMAIL(ByVal MailSubject As String, ByVal MessageBody As String, ByVal ToAddresses As String) As Boolean
'SendEmailGMAIL("subject","messagebody","address1;address2;...")
Try
Dim Mail As New MailMessage()
Mail.Subject = MailSubject
Mail.From = New System.Net.Mail.MailAddress(GMAILUSER)
For Each Address As String In Split(ToAddresses, ";")
Mail.To.Add(Address)
Next
Mail.Body = MessageBody
Dim SmtpServer As New SmtpClient()
SmtpServer.Credentials = New Net.NetworkCredential(GMAILUSER, GMAILPASS)
SmtpServer.Host = GMAILSMTPHOST
SmtpServer.Port = GMAILSMTPPORT
SmtpServer.EnableSsl = GMAILbEnableSSL
SmtpServer.Send(Mail)
Return True
Catch ex As Exception
Console.WriteLine(ex.Message)
Return False
End Try
End Function
End Class
Clase Visual Basic .NET para grabar / mostrar un archivo de texto (log)
Imports System.IO
Public Class clsLog
Dim m_filename As String = ""
Private m_sw As StreamWriter = Nothing
Private m_bAppend As Boolean
Public Sub New(ByVal strPathLogFile As String, Optional ByVal bAppend As Boolean = True)
m_filename = strPathLogFile
m_bAppend = bAppend
Try
m_sw = New StreamWriter(m_filename, bAppend)
m_sw.Close()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Sub
Protected Overrides Sub Finalize()
Dispose()
MyBase.Finalize()
End Sub
Private Sub Dispose()
Try
m_sw = Nothing
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Sub
Public Sub Log(strValue As String)
Try
m_sw = New StreamWriter(m_filename, m_bAppend)
m_sw.WriteLine(strValue)
m_sw.Flush()
m_sw.Close()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Sub
Public Sub ShowLog()
If System.IO.File.Exists(m_filename) Then
Process.Start(m_filename)
End If
End Sub
End Class
Public Class clsLog
Dim m_filename As String = ""
Private m_sw As StreamWriter = Nothing
Private m_bAppend As Boolean
Public Sub New(ByVal strPathLogFile As String, Optional ByVal bAppend As Boolean = True)
m_filename = strPathLogFile
m_bAppend = bAppend
Try
m_sw = New StreamWriter(m_filename, bAppend)
m_sw.Close()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Sub
Protected Overrides Sub Finalize()
Dispose()
MyBase.Finalize()
End Sub
Private Sub Dispose()
Try
m_sw = Nothing
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Sub
Public Sub Log(strValue As String)
Try
m_sw = New StreamWriter(m_filename, m_bAppend)
m_sw.WriteLine(strValue)
m_sw.Flush()
m_sw.Close()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Sub
Public Sub ShowLog()
If System.IO.File.Exists(m_filename) Then
Process.Start(m_filename)
End If
End Sub
End Class
Clase Visual Basic .NET con función para obtener datos GeoIP (Ip pública y localización) y función para obtener el nombre del host a partir de una IP
Imports System.Net
'http://www.vbforums.com/showthread.php?637319-VB-Net-Simple-function-to-get-external-IP-adress
Public Class clsExternalIPAddress
Public Structure ExternalIPData
Dim IP As String
Dim CountryCode As String
Dim CountryName As String
Dim RegionCode As String
Dim RegionName As String
Dim City As String
Dim TimeZone As String
Dim Latitude As Double
Dim Longitude As Double
End Structure
Public Function GeoIP(Optional IP As String = Nothing) As ExternalIPData
Dim IPData As New ExternalIPData
Using client = New WebClient()
Try
Dim strFile As String
If IsNothing(IP) Then
strFile = client.DownloadString("http://freegeoip.net/xml")
Else
strFile = client.DownloadString(String.Format("http://freegeoip.net/xml/{0}", IP))
End If
Dim response As XElement = XElement.Parse(strFile)
With IPData
.IP = response.Element("IP").Value
.CountryCode = response.Element("CountryCode").Value
.CountryName = response.Element("CountryName").Value
.RegionCode = response.Element("RegionCode").Value
.RegionName = response.Element("RegionName").Value
.City = response.Element("City").Value
.TimeZone = response.Element("TimeZone").Value
.Latitude = CType(response.Element("Latitude").Value, Long)
.Longitude = CType(response.Element("Longitude").Value, Long)
End With
Catch ex As Exception
Return Nothing
End Try
End Using
Return IPData
End Function
Public Function GetExternalIP() As String
Try
Return GeoIP.IP
Catch ex As Exception
Console.WriteLine(ex.Message)
Return ""
End Try
End Function
Public Function GetHostNameFromIP() As String
Try
Dim host As System.Net.IPHostEntry
host = System.Net.Dns.GetHostEntry(GeoIP.IP)
Return host.HostName
Catch ex As Exception
Return ""
End Try
End Function
End Class
'http://www.vbforums.com/showthread.php?637319-VB-Net-Simple-function-to-get-external-IP-adress
Public Class clsExternalIPAddress
Public Structure ExternalIPData
Dim IP As String
Dim CountryCode As String
Dim CountryName As String
Dim RegionCode As String
Dim RegionName As String
Dim City As String
Dim TimeZone As String
Dim Latitude As Double
Dim Longitude As Double
End Structure
Public Function GeoIP(Optional IP As String = Nothing) As ExternalIPData
Dim IPData As New ExternalIPData
Using client = New WebClient()
Try
Dim strFile As String
If IsNothing(IP) Then
strFile = client.DownloadString("http://freegeoip.net/xml")
Else
strFile = client.DownloadString(String.Format("http://freegeoip.net/xml/{0}", IP))
End If
Dim response As XElement = XElement.Parse(strFile)
With IPData
.IP = response.Element("IP").Value
.CountryCode = response.Element("CountryCode").Value
.CountryName = response.Element("CountryName").Value
.RegionCode = response.Element("RegionCode").Value
.RegionName = response.Element("RegionName").Value
.City = response.Element("City").Value
.TimeZone = response.Element("TimeZone").Value
.Latitude = CType(response.Element("Latitude").Value, Long)
.Longitude = CType(response.Element("Longitude").Value, Long)
End With
Catch ex As Exception
Return Nothing
End Try
End Using
Return IPData
End Function
Public Function GetExternalIP() As String
Try
Return GeoIP.IP
Catch ex As Exception
Console.WriteLine(ex.Message)
Return ""
End Try
End Function
Public Function GetHostNameFromIP() As String
Try
Dim host As System.Net.IPHostEntry
host = System.Net.Dns.GetHostEntry(GeoIP.IP)
Return host.HostName
Catch ex As Exception
Return ""
End Try
End Function
End Class
Clase Visual Basic .NET comprueba si un puerto TCP está abierto
Public Class clsHostPort
Private m_hostname As String
Private m_port As Integer
Private m_timeout As Integer
Private m_bIsOpen As Boolean
Sub New(ByVal HostName As String, ByVal Port As Integer, Optional ByVal timeout As Integer = 10)
'127.0.0.1 is the local machine
m_hostname = HostName
m_port = Port
m_timeout = timeout
m_bIsOpen = False
End Sub
Public Function IsPortOpen() As Boolean
'first check valid port value
If m_port >= 0 And m_port < 65536 Then
Else
Return False
End If
Dim Client As System.Net.Sockets.TcpClient = Nothing
Try
Client = New System.Net.Sockets.TcpClient(m_hostname, m_port)
Client.ReceiveTimeout = m_timeout
m_bIsOpen = True
Catch ex As System.Net.Sockets.SocketException
Console.WriteLine(ex.Message)
m_bIsOpen = False
Finally
If Not Client Is Nothing Then
Client.Close()
End If
IsPortOpen = m_bIsOpen
End Try
End Function
End Class
Private m_hostname As String
Private m_port As Integer
Private m_timeout As Integer
Private m_bIsOpen As Boolean
Sub New(ByVal HostName As String, ByVal Port As Integer, Optional ByVal timeout As Integer = 10)
'127.0.0.1 is the local machine
m_hostname = HostName
m_port = Port
m_timeout = timeout
m_bIsOpen = False
End Sub
Public Function IsPortOpen() As Boolean
'first check valid port value
If m_port >= 0 And m_port < 65536 Then
Else
Return False
End If
Dim Client As System.Net.Sockets.TcpClient = Nothing
Try
Client = New System.Net.Sockets.TcpClient(m_hostname, m_port)
Client.ReceiveTimeout = m_timeout
m_bIsOpen = True
Catch ex As System.Net.Sockets.SocketException
Console.WriteLine(ex.Message)
m_bIsOpen = False
Finally
If Not Client Is Nothing Then
Client.Close()
End If
IsPortOpen = m_bIsOpen
End Try
End Function
End Class
Función Visual Basic .NET ejecuta cualquier instrucción SQL sin afectar a la base de datos SQL Server (SET FMTONLY ON)
'Puede ser util si quieres comprobar si una instrucción sql se ejecutará correctamente sin afectar a la base de datos.
Private Function CheckSql(ByVal nOrden As Integer, ByVal Sql As String, ByVal cnStr As String) As String
Dim report As String = ""
Dim SqlNoExec As String = "SET FMTONLY ON"
Dim cn As SqlClient.SqlConnection
Dim value As Integer
Try
cn = New SqlClient.SqlConnection(cnStr)
cn.Open()
'lanzamos instruccion contra el servidor SQL para evitar cualquier cambio
Dim cmd As New SqlClient.SqlCommand(SqlNoExec, cn)
'ejecutamos SET FMTONLY ON en la base de datos
value = cmd.ExecuteNonQuery()
If value = -1 Then
'a partir de este momento lo que ejecutemos no tendra efecto sobre la base de datos
cmd.CommandText = Sql
value = cmd.ExecuteNonQuery()
End If
cmd.Dispose()
cmd = Nothing
'en este punto el comando SET FMONLY ON ya no afecta, pues esta ligado a la vida del objeto cmd
report = String.Format("{0,-8} {1,-12} {2} {3}", "OK", "Orden: " & nOrden, " SQL: " & Sql, vbTab & " ConnString: " & cnStr)
Catch ex As Exception
report = String.Format("{0,-8} {1,-12} {2} {3} {4}", "ERROR", "Orden: " & nOrden, " SQL: " & Sql, vbTab & " ConnString: " & cnStr, vbCrLf & ex.Message)
End Try
Return report
End Function
Private Function CheckSql(ByVal nOrden As Integer, ByVal Sql As String, ByVal cnStr As String) As String
Dim report As String = ""
Dim SqlNoExec As String = "SET FMTONLY ON"
Dim cn As SqlClient.SqlConnection
Dim value As Integer
Try
cn = New SqlClient.SqlConnection(cnStr)
cn.Open()
'lanzamos instruccion contra el servidor SQL para evitar cualquier cambio
Dim cmd As New SqlClient.SqlCommand(SqlNoExec, cn)
'ejecutamos SET FMTONLY ON en la base de datos
value = cmd.ExecuteNonQuery()
If value = -1 Then
'a partir de este momento lo que ejecutemos no tendra efecto sobre la base de datos
cmd.CommandText = Sql
value = cmd.ExecuteNonQuery()
End If
cmd.Dispose()
cmd = Nothing
'en este punto el comando SET FMONLY ON ya no afecta, pues esta ligado a la vida del objeto cmd
report = String.Format("{0,-8} {1,-12} {2} {3}", "OK", "Orden: " & nOrden, " SQL: " & Sql, vbTab & " ConnString: " & cnStr)
Catch ex As Exception
report = String.Format("{0,-8} {1,-12} {2} {3} {4}", "ERROR", "Orden: " & nOrden, " SQL: " & Sql, vbTab & " ConnString: " & cnStr, vbCrLf & ex.Message)
End Try
Return report
End Function
Función Visual Basic .NET para contar los registros de una tabla pasando como parámetro la instrucción SQL select count(*) from nombre_tabla
Public Function RegCountTable(ByVal Sql As String, ByVal ConnectionString As String) As Int32
'ejemplo parámetro Sql = "select count(*) from nombre_tabla"
Dim res As Int32 = -1
Try
Dim cn As New SqlConnection(ConnectionString)
cn.Open()
Dim cmd As New SqlCommand(Sql, cn)
res = Convert.ToInt32(cmd.ExecuteScalar())
cn.Close()
cn = Nothing
Catch ex As Exception
Debug.WriteLine(Sql & " " & ex.Message)
End Try
Return res
End Function
'ejemplo parámetro Sql = "select count(*) from nombre_tabla"
Dim res As Int32 = -1
Try
Dim cn As New SqlConnection(ConnectionString)
cn.Open()
Dim cmd As New SqlCommand(Sql, cn)
res = Convert.ToInt32(cmd.ExecuteScalar())
cn.Close()
cn = Nothing
Catch ex As Exception
Debug.WriteLine(Sql & " " & ex.Message)
End Try
Return res
End Function
Funciones en Visual Basic .NET para obtener la lista de tablas de una base de datos Access o una base de datos SQL Server
Imports System.Data.SqlClient
Imports ADODB
....
Private Function GetTableListSQLServerDB(ByVal cnStr As String) As List(Of String)
Dim lstTables As New List(Of String)
If Not cnStr.ToLower.Contains("provider") Then
cnStr = "Provider = sqloledb;" & cnStr
End If
Try
Dim cn As New ADODB.Connection()
cn.ConnectionString = cnStr
cn.Open()
Dim rs As New ADODB.Recordset()
rs = cn.OpenSchema(SchemaEnum.adSchemaTables)
Do While Not rs.EOF
If rs.Fields("TABLE_TYPE").Value.ToString = "TABLE" Then
lstTables.Add(rs.Fields("TABLE_NAME").Value)
End If
rs.MoveNext()
Loop
rs.Close()
cn.Close()
rs = Nothing
cn = Nothing
Catch ex As Exception
MsgBox(ex.Message)
Debug.WriteLine(ex.Message)
End Try
Return lstTables
End Function
Private Function GetTableListAccess(strPathNameAccessDB As String) As List(Of String)
Dim lstTables As New List(Of String)
Try
Dim cnStr As String = "Provider = Microsoft.ACE.OLEDB.12.0; data source= " & strPathNameAccessDB
Dim cn As New ADODB.Connection()
cn.ConnectionString = cnStr
cn.Open()
Dim rs As New ADODB.Recordset()
rs = cn.OpenSchema(SchemaEnum.adSchemaTables)
Do While Not rs.EOF
If rs.Fields("TABLE_TYPE").Value.ToString = "TABLE" Then
lstTables.Add(rs.Fields("TABLE_NAME").Value.ToString)
End If
rs.MoveNext()
Loop
rs.Close()
cn.Close()
rs = Nothing
cn = Nothing
Catch ex As Exception
MsgBox(ex.Message)
Debug.WriteLine(ex.Message)
End Try
Return lstTables
End Function
Imports ADODB
....
Private Function GetTableListSQLServerDB(ByVal cnStr As String) As List(Of String)
Dim lstTables As New List(Of String)
If Not cnStr.ToLower.Contains("provider") Then
cnStr = "Provider = sqloledb;" & cnStr
End If
Try
Dim cn As New ADODB.Connection()
cn.ConnectionString = cnStr
cn.Open()
Dim rs As New ADODB.Recordset()
rs = cn.OpenSchema(SchemaEnum.adSchemaTables)
Do While Not rs.EOF
If rs.Fields("TABLE_TYPE").Value.ToString = "TABLE" Then
lstTables.Add(rs.Fields("TABLE_NAME").Value)
End If
rs.MoveNext()
Loop
rs.Close()
cn.Close()
rs = Nothing
cn = Nothing
Catch ex As Exception
MsgBox(ex.Message)
Debug.WriteLine(ex.Message)
End Try
Return lstTables
End Function
Private Function GetTableListAccess(strPathNameAccessDB As String) As List(Of String)
Dim lstTables As New List(Of String)
Try
Dim cnStr As String = "Provider = Microsoft.ACE.OLEDB.12.0; data source= " & strPathNameAccessDB
Dim cn As New ADODB.Connection()
cn.ConnectionString = cnStr
cn.Open()
Dim rs As New ADODB.Recordset()
rs = cn.OpenSchema(SchemaEnum.adSchemaTables)
Do While Not rs.EOF
If rs.Fields("TABLE_TYPE").Value.ToString = "TABLE" Then
lstTables.Add(rs.Fields("TABLE_NAME").Value.ToString)
End If
rs.MoveNext()
Loop
rs.Close()
cn.Close()
rs = Nothing
cn = Nothing
Catch ex As Exception
MsgBox(ex.Message)
Debug.WriteLine(ex.Message)
End Try
Return lstTables
End Function
Clase en Visual Basic .NET que crea un cronometro conectado a una etiqueta (stopwach)
Public Class clsTimerSW
Private m_timer As Timer
Private m_sw As Stopwatch
Private m_lbl As Label = Nothing
Sub New(ByVal msInterval As Integer, Optional ByRef lbl As Label = Nothing)
m_lbl = lbl
m_timer = New Timer()
m_timer.Interval = msInterval
AddHandler m_timer.Tick, AddressOf m_timer_Tick
m_sw = New Stopwatch()
End Sub
Public Sub StartTimerSW()
If Not m_lbl Is Nothing Then m_lbl.Text = ""
m_sw.Start()
m_timer.Enabled = True
End Sub
Public Sub StopTimerSW()
m_sw.Stop()
m_timer.Enabled = False
End Sub
Public Sub ResetTimerSW()
m_sw.Restart()
If Not m_lbl Is Nothing Then
m_lbl.Text = GetElapsedTime()
End If
End Sub
Public Sub SetInterval(ByVal ms As Integer)
m_timer.Interval = ms
End Sub
Public Function IsEnabled() As Boolean
Return m_timer.Enabled
End Function
Public Function GetElapsedTime() As String
Return String.Format("{0}:{1}:{2}", _
m_sw.Elapsed.Hours.ToString("00"), _
m_sw.Elapsed.Minutes.ToString("00"), _
m_sw.Elapsed.Seconds.ToString("00"))
End Function
Private Sub m_timer_Tick(sender As Object, e As EventArgs)
If Not m_lbl Is Nothing Then
m_lbl.Text = GetElapsedTime()
m_lbl.Refresh()
End If
End Sub
End Class
Private m_timer As Timer
Private m_sw As Stopwatch
Private m_lbl As Label = Nothing
Sub New(ByVal msInterval As Integer, Optional ByRef lbl As Label = Nothing)
m_lbl = lbl
m_timer = New Timer()
m_timer.Interval = msInterval
AddHandler m_timer.Tick, AddressOf m_timer_Tick
m_sw = New Stopwatch()
End Sub
Public Sub StartTimerSW()
If Not m_lbl Is Nothing Then m_lbl.Text = ""
m_sw.Start()
m_timer.Enabled = True
End Sub
Public Sub StopTimerSW()
m_sw.Stop()
m_timer.Enabled = False
End Sub
Public Sub ResetTimerSW()
m_sw.Restart()
If Not m_lbl Is Nothing Then
m_lbl.Text = GetElapsedTime()
End If
End Sub
Public Sub SetInterval(ByVal ms As Integer)
m_timer.Interval = ms
End Sub
Public Function IsEnabled() As Boolean
Return m_timer.Enabled
End Function
Public Function GetElapsedTime() As String
Return String.Format("{0}:{1}:{2}", _
m_sw.Elapsed.Hours.ToString("00"), _
m_sw.Elapsed.Minutes.ToString("00"), _
m_sw.Elapsed.Seconds.ToString("00"))
End Function
Private Sub m_timer_Tick(sender As Object, e As EventArgs)
If Not m_lbl Is Nothing Then
m_lbl.Text = GetElapsedTime()
m_lbl.Refresh()
End If
End Sub
End Class
Clase en Visual Basic .NET para crear una base de datos access ACCDB, crear tablas e insertar registros
Imports Microsoft.Office.Interop.Access.Dao
Public Class clsAccessCreator
Public Function CreateAccessFile(ByVal strPathFile As String) As Boolean
Dim res As Boolean = True
Try
Dim AccessDatabaseEngine As New Microsoft.Office.Interop.Access.Dao.DBEngine
Dim AccessDatabase As Microsoft.Office.Interop.Access.Dao.Database
AccessDatabase = AccessDatabaseEngine.CreateDatabase(strPathFile, LanguageConstants.dbLangGeneral, DatabaseTypeEnum.dbVersion120)
AccessDatabase.Close()
Using conn As New OleDb.OleDbConnection("Provider=Microsoft.ACE.OLEDB.12.0;" & _
" Data Source=" & strPathFile & ";Persist Security Info=False;")
'Create tables
Using cmd As New OleDb.OleDbCommand("CREATE TABLE Conexiones ( " & _
"Id int NOT NULL," & _
"Orden int NOT NULL," & _
"BasedeDatos NVarchar(255) NOT NULL," & _
"CadenaConexion text NOT NULL," & _
"CONSTRAINT Id_PK PRIMARY KEY(Id)) ", conn)
conn.Open()
Try
cmd.ExecuteNonQuery()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Using
Using cmd As New OleDb.OleDbCommand("CREATE TABLE Tablas ( " & _
"Id int NOT NULL ," & _
"Orden int NOT NULL," & _
"BasedeDatos NVarchar(255) NOT NULL," & _
"NombreTabla NVarchar(255) NOT NULL," & _
"Condicion Text," & _
"CONSTRAINT Id_PK PRIMARY KEY(Id)) ", conn)
Try
cmd.ExecuteNonQuery()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Using
'Insert values
Try
'Conexiones
Dim Sql As String
Sql = "INSERT INTO Conexiones(Id,Orden,BasedeDatos,CadenaConexion) VALUES(1, 1,'Cont','Data Source=.\;Initial Catalog=Cont;Integrated Security=SSPI;');"
Dim cmdI As New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Conexiones(Id,Orden,BasedeDatos,CadenaConexion) VALUES(2, 2,'Gest','Data Source=.\;Initial Catalog=Gest;User ID=sa;Password=1234;');"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
'Operaciones
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(1, 1,'Cont','Table_1',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(2, 2,'Cont','Table_2',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(3, 3,'Gest','Table_1',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(4, 4,'Gest','Table_2',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Using
Catch ex As Exception
MsgBox(ex.Message)
Debug.WriteLine(ex.Message)
End Try
Return res
End Function
End Class
Public Class clsAccessCreator
Public Function CreateAccessFile(ByVal strPathFile As String) As Boolean
Dim res As Boolean = True
Try
Dim AccessDatabaseEngine As New Microsoft.Office.Interop.Access.Dao.DBEngine
Dim AccessDatabase As Microsoft.Office.Interop.Access.Dao.Database
AccessDatabase = AccessDatabaseEngine.CreateDatabase(strPathFile, LanguageConstants.dbLangGeneral, DatabaseTypeEnum.dbVersion120)
AccessDatabase.Close()
Using conn As New OleDb.OleDbConnection("Provider=Microsoft.ACE.OLEDB.12.0;" & _
" Data Source=" & strPathFile & ";Persist Security Info=False;")
'Create tables
Using cmd As New OleDb.OleDbCommand("CREATE TABLE Conexiones ( " & _
"Id int NOT NULL," & _
"Orden int NOT NULL," & _
"BasedeDatos NVarchar(255) NOT NULL," & _
"CadenaConexion text NOT NULL," & _
"CONSTRAINT Id_PK PRIMARY KEY(Id)) ", conn)
conn.Open()
Try
cmd.ExecuteNonQuery()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Using
Using cmd As New OleDb.OleDbCommand("CREATE TABLE Tablas ( " & _
"Id int NOT NULL ," & _
"Orden int NOT NULL," & _
"BasedeDatos NVarchar(255) NOT NULL," & _
"NombreTabla NVarchar(255) NOT NULL," & _
"Condicion Text," & _
"CONSTRAINT Id_PK PRIMARY KEY(Id)) ", conn)
Try
cmd.ExecuteNonQuery()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Using
'Insert values
Try
'Conexiones
Dim Sql As String
Sql = "INSERT INTO Conexiones(Id,Orden,BasedeDatos,CadenaConexion) VALUES(1, 1,'Cont','Data Source=.\;Initial Catalog=Cont;Integrated Security=SSPI;');"
Dim cmdI As New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Conexiones(Id,Orden,BasedeDatos,CadenaConexion) VALUES(2, 2,'Gest','Data Source=.\;Initial Catalog=Gest;User ID=sa;Password=1234;');"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
'Operaciones
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(1, 1,'Cont','Table_1',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(2, 2,'Cont','Table_2',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(3, 3,'Gest','Table_1',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Sql = "INSERT INTO Tablas(Id,Orden,BasedeDatos,NombreTabla,Condicion) VALUES(4, 4,'Gest','Table_2',NULL);"
cmdI = New OleDb.OleDbCommand(Sql, conn)
cmdI.ExecuteNonQuery()
Catch ex As Exception
Debug.WriteLine(ex.Message)
End Try
End Using
Catch ex As Exception
MsgBox(ex.Message)
Debug.WriteLine(ex.Message)
End Try
Return res
End Function
End Class
Suscribirse a:
Entradas (Atom)
VBA Access. Redondeo de números decimales con el método medio redondeo. Alternativa a la función Round (bankers round)
Private Function Redondeo(ByVal Numero As Variant, ByVal Decimales As Integer) As Double 'Aplica método medio redondeo (half round ...
-
Option Compare Database Option Explicit '***************************** ' 'Ejemplo de uso ' 'selecciona 1 ficher...
-
Option Compare Database Option Explicit 'Zip / UnZip file or folder 'http://www.codekabinett.com/rdumps.php?Lang=2&targetDoc...