Saludos a todos soy nuevo aqui en esta pagina, me gustaria saber como le hago para leer los datos de hyperterminal del puerto serial para llevarlo a una hoja de excel en un macro y luego enviarlo via email a mi correro (outlook). he utilizado varios codigos genericos par intentar leer pero no consigo ver nada corro la macro y lo unico que sale es Debug 424. realmente no se donde esta el erro pues son codigos genericos de comunicacion via puerto serial. aqui les dejo los codigo que uso para leer los datos que suben a hyperteminal por el puerto comm 1 y luego enviarlos a por email.... Gracias
Private Sub MSComm1_OnComm()
SelectCase MScomm1.CommEvent
Case comEventBreak ' A Break was received.
Case comEventCDTO ' CD (RLSD) Timeout.
Case comEventCTSTO ' CTS Timeout.
Case comEventDSRTO ' DSR Timeout.
Case comEventFrame ' Framing Error.
Case comEventOverrun ' Data Lost.
Case comEventRxOver ' Receive buffer overflow.
Case comEventRxParity ' Parity Error.
Case comEventTxFull ' Transmit buffer full.
Case comEventDCB ' Unexpected error retrieving DCB]
' Events
Case comEvCD ' Change in the CD line.
Case comEvCTS ' Change in the CTS line.
Case comEvDSR ' Change in the DSR line.
Case comEvRing ' Change in the Ring Indicator.
Case comEvReceive ' Received RThreshold # of chars.
'Sets the global mstinbuff to = what is received by the commm control
mstInBuff = mstInBuff & MScomm1.Input
'Resets the variable used to count the lack of response to 0 so that
'counting restarts.
mdblReceived = 0
End Select
End Sub
Sub CDO_Send_Selection_Body()
Dim LastRow As Long
Dim Source As Range
Dim Dest As Workbook
Dim wb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim OutApp As Object
Dim OutMail As Object
If WorksheetFunction.CountA(Cells) > 0 Then
LastRow = Cells.Find(What:="*", After:=[C1], _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
End If
Set sh = Sheets("DataLog") '<<< Change
Set Source = sh.Range("A" & LastRow & ":C" & LastRow) '<<< Change
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set wb = ActiveWorkbook
Set Dest = Workbooks.Add(xlWBATWorksheet)
Source.Copy
With Dest.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial Paste:=xlPasteValues
.Cells(1).PasteSpecial Paste:=xlPasteFormats
.Cells(1).Select
Application.CutCopyMode = False
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Selection of " & wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
With Dest
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "neurin.rodriguez@hospira.com"
.CC = ""
.BCC = ""
.From = """Sistema de Alarmas"" <neurin.rodriguez@hospira.com>"
.Subject = " "
.HTMLBody = vbCr & vbCr & "[" & Format(sh.Range("B" & LastRow).Value, "HH:MM AM/PM") & "] EVENTO: " & sh.Range("C" & LastRow).Value 'RangetoHTML(sh, rng)
.Send
End With
On Error GoTo 0
.Close savechanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Function RangetoHTML(rng As Range)
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8
.Cells(1).PasteSpecial xlPasteValues, , False, False
.Cells(1).PasteSpecial xlPasteFormats, , False, False
.Cells(1).Select
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub CDO_Send_ActiveSheet_Body_Without_Pictures()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = Sheets("DataLog").UsedRange
'Set rng = Sheets("DataLog").Range("A4:C" & LastRow).SpecialCells(xlCellTypeVisible)
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Sheet1.Email1.Value
.CC = Sheet1.Email2.Value
.BCC = ""
.Subject = "Reporte de Alarmas para: " & Format(Range("A4").Value, "MM/DD/YYYY")
.HTMLBody = RangetoHTML(rng)
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Public Function SheetToHTML(sh As Worksheet)
'Function from Dick Kusleika his site
'
http://www.dicks-clicks.com/excel/sheettohtml.htm'Changed by Ron de Bruin 19-Aug-2006
Dim TempFile As String
Dim Nwb As Workbook
Dim fso As Object
Dim ts As Object
sh.Copy
Set Nwb = ActiveWorkbook
With Nwb.Sheets(1)
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
TempFile = Environ$("tempII") & "/" & _
Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
Nwb.SaveAs TempFile, xlHtml
Nwb.Close False
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
SheetToHTML = ts.ReadAll
ts.Close
On Error Resume Next
Kill TempFile
fso.deletefolder Left(TempFile, Len(TempFile) - 4) & "*", True
On Error GoTo 0
Set ts = Nothing
Set fso = Nothing
Set Nwb = Nothing
End Function
Option Explicit
