Hallo allemaal,
Ik heb een programma gemaakt welke van drie COM-poorten de data inleest en doorvoert naar resp. ExcelSheet(1), ExcelSheet(2) en ExcelSheet(3).
Dit werkt op zich redelijk goed, alleen mijn opdracht om naar de volgende regel (Row) te gaan werkt voor alledrie de sheets tegelijk. Hierdoor krijg ik steeds lege regels er tussendoor in elk van de sheets.
Wie weet hoe ik de code zó kan maken dat ik in elke Sheet apart een regel kan toevoegen.
Ik heb nu gebruikt : ExcelRow = ExcelRow + 1 in elk van de On CommEvents van de poorten.
hier de code: ( kijk vooral bij Private Sub rs232_OnComm)
Option Explicit
Dim ExcelApp As Excel.Application
Dim ExcelCht As Excel.Chart
Dim ExcelSht1 As Excel.Worksheet
Dim ExcelSht2 As Excel.Worksheet
Dim ExcelSht3 As Excel.Worksheet
Dim ExcelWkb As Excel.Workbook
Dim MyExcel As Boolean
Dim ExcelRowActive As Integer
Dim ExcelColActive As Integer
Dim ExcelRow As Integer
Dim ExcelCol As Integer
Dim VolgNr1 As Integer
Dim VolgNr2 As Integer
Dim VolgNr3 As Integer
Dim Gemiddelde1 As Double
Dim Gemiddelde2 As Double
Dim Gemiddelde3 As Double
Dim Totaal1 As Double
Dim Totaal2 As Double
Dim Totaal3 As Double
Dim Buffer As Double
Dim Row, Col As Integer
Private Sub Command1_Click()
'schakel naar Exel
ExcelApp.Visible = True
End Sub
Private Sub Command2_Click()
cdlExample.ShowOpen
Shell "C:\Program Files\Microsoft Office\Office11\Excel.exe" & " " & cdlExample.FileName
End Sub
Private Sub Timer1_Timer()
Label4.Caption = Now
End Sub
Private Sub Form_Load()
Me.Show
DoEvents
VolgNr1 = 0
VolgNr2 = 0
VolgNr3 = 0
Totaal1 = 0
Totaal2 = 0
Totaal3 = 0
cdlExample.InitDir = "E:\" 'instelling Openfile menu
cdlExample.Filter = "Excel Docs (*.xls)|*.xls"
cdlExample.FileName = ""
On Error Resume Next
File1.FileName = "E:\*.xls"
'Excel openen en Sheets benoemen
On Error Resume Next
Err.Clear
Set ExcelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set ExcelApp = CreateObject("Excel.Application")
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Description
Else
MyExcel = True
End If
Else
MyExcel = False
End If
ExcelApp.Visible = True
Set ExcelWkb = ExcelApp.Workbooks.Add
Set ExcelSht1 = ExcelWkb.Worksheets(1)
Set ExcelSht2 = ExcelWkb.Worksheets(2)
Set ExcelSht3 = ExcelWkb.Worksheets(3)
ExcelSht1.Name = "Scale 1"
ExcelSht1.PageSetup.CenterHeader = "Results Scale 1" & " " & Date
ExcelSht1.PageSetup.PrintGridlines = True
ExcelSht2.Name = "Scale 2"
ExcelSht2.PageSetup.CenterHeader = "Results Scale 2" & " " & Date
ExcelSht2.PageSetup.PrintGridlines = True
ExcelSht3.Name = "Scale 3"
ExcelSht3.PageSetup.CenterHeader = "Results Scale 3" & " " & Date
ExcelSht3.PageSetup.PrintGridlines = True
'set actieve cel
ExcelRowActive = ExcelApp.ActiveCell.Row
ExcelColActive = ExcelApp.ActiveCell.Column
ExcelRow = ExcelRowActive
ExcelCol = ExcelColActive
'maak grafiek
Set ExcelCht = ExcelWkb.Charts.Add
ExcelCht.ChartType = xlLineMarkers
ExcelCht.HasTitle = True
ExcelCht.ChartTitle.Characters.Text = "3 Scales"
ExcelCht.Axes(xlCategory, xlPrimary).HasTitle = True
ExcelCht.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "X-Axis"
ExcelCht.Axes(xlValue, xlPrimary).HasTitle = True
ExcelCht.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Weight Scales"
ExcelCht.Name = "Chart All Scales"
With Selection.Border
.ColorIndex = 57
.Weight = xlThick
.LineStyle = xlContinuous
End With
Me.SetFocus
If rs232.PortOpen = True Then rs232.PortOpen = False
If rs232b.PortOpen = True Then rs232b.PortOpen = False
If rs232c.PortOpen = True Then rs232c.PortOpen = False
rs232.CommPort = 6
rs232.PortOpen = True
rs232.Settings = "9600,N,8,1"
rs232.CommEvent = 0
rs232b.CommPort = 7
rs232b.PortOpen = True
rs232b.Settings = "9600,N,8,1"
rs232b.CommEvent = 0
rs232c.CommPort = 9
rs232c.PortOpen = True
rs232c.Settings = "9600,N,8,1"
rs232c.CommEvent = 0
End Sub
Private Sub quitprogram_Click()
Dim fso As New FileSystemObject
Dim Drive As Drive
If fso.DriveExists("E:") Then
MsgBox ("USB stick is available !"), vbOKOnly 'Er is een floppy
Else: MsgBox ("put in the USB stick !"), vbOKOnly
' On Error Resume Next
'Set Drive = fso.GetDrive("E:")
End If
If MyExcel Then
ExcelApp.ActiveWorkbook.SaveAs "E:\" & Date & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Else: Exit Sub
ExcelApp.Quit
End If
End
End Sub
Private Sub rs232_OnComm():
VolgNr1 = VolgNr1 + 1
rs232.InputLen = 16
rs232.RThreshold = 16
Select Case rs232.CommEvent
' Handle each event or error by placing
Case comEvReceive ' Received RThreshold # of
' chars.
Text2 = Val(rs232.Input)
End Select
If Text2 = "0" Then 'Bij tarreren of 0g geen overdracht naar Excel
VolgNr1 = VolgNr1 - 1 'VolgNr1 terugzetten
Exit Sub
End If
On Error Resume Next
Totaal1 = Totaal1 + Text2
Gemiddelde1 = Totaal1 / VolgNr1
Text1.Text = Gemiddelde1
Text3.Text = VolgNr1
ExcelSht1.Cells(ExcelRow, ExcelCol) = VolgNr1
ExcelSht1.Cells(ExcelRow, ExcelCol + 1) = Format(Time, "h:mm:ss")
ExcelSht1.Cells(ExcelRow, ExcelCol + 2) = Text2
ExcelSht1.Cells(ExcelRow, ExcelCol + 3) = Gemiddelde1
ExcelSht1.Range("D
").NumberFormat = "0.0"
'voeg grafiekgegevns toe
'ExcelCht.SetSourceData ExcelSht1.Range("D"), xlColumns
ExcelRow = VolgNr1 + 1
(De bovenstaande regel veroorzaakt in alledrie de sheets een extra regel, dit moet alleen in de eerste sheet zijn. En dan bij rs232b_OnComm de tweede sheet enz.)
'zet grafiek in werkscherm
On Error Resume Next
'ExcelCht.ChartArea.Select
'ExcelCht.ChartArea.Copy
'Image2.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
Private Sub rs232b_OnComm()
VolgNr2 = VolgNr2 + 1
rs232b.InputLen = 16
rs232b.RThreshold = 16
Select Case rs232b.CommEvent
' Handle each event or error by placing
Case comEvReceive ' Received RThreshold # of
' chars.
Text6 = Val(rs232b.Input)
End Select
If Text6 = "0" Then 'Bij tarreren of 0g geen overdracht naar Excel
VolgNr2 = VolgNr2 - 1 'VolgNr2 terugzetten
Exit Sub
End If
On Error Resume Next
Totaal2 = Totaal2 + Text6
Gemiddelde2 = Totaal2 / VolgNr2
Text5.Text = Gemiddelde2
Text4.Text = VolgNr2
ExcelSht2.Cells(ExcelRow, ExcelCol) = VolgNr2
ExcelSht2.Cells(ExcelRow, ExcelCol + 1) = Format(Time, "h:mm:ss")
ExcelSht2.Cells(ExcelRow, ExcelCol + 2) = Text6
ExcelSht2.Cells(ExcelRow, ExcelCol + 3) = Gemiddelde2
ExcelSht2.Range("D").NumberFormat = "0.0"
'voeg grafiekgegevns toe
'ExcelCht.SetSourceData ExcelSht2.Range("D"), xlColumns
ExcelRow = VolgNr2 + 1
'zet grafiek in werkscherm
On Error Resume Next
'ExcelCht.ChartArea.Select
'ExcelCht.ChartArea.Copy
'Image2.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
Private Sub rs232c_OnComm()
VolgNr3 = VolgNr3 + 1
rs232c.InputLen = 16
rs232c.RThreshold = 16
Select Case rs232c.CommEvent
' Handle each event or error by placing
Case comEvReceive ' Received RThreshold # of
' chars.
Text7 = Val(rs232c.Input)
End Select
If Text7 = "0" Then 'Bij tarreren of 0g geen overdracht naar Excel
VolgNr3 = VolgNr3 - 1 'VolgNr1 terugzetten
Exit Sub
End If
On Error Resume Next
Totaal3 = Totaal3 + Text7
Gemiddelde3 = Totaal3 / VolgNr3
Text8.Text = Gemiddelde3
Text9.Text = VolgNr3
ExcelApp.Sheets("Scale 3").Select
ExcelSht3.Cells(ExcelRow, ExcelCol) = VolgNr3
ExcelSht3.Cells(ExcelRow, ExcelCol + 1) = Format(Time, "h:mm:ss")
ExcelSht3.Cells(ExcelRow, ExcelCol + 2) = Text7
ExcelSht3.Cells(ExcelRow, ExcelCol + 3) = Gemiddelde3
ExcelSht3.Range("D").NumberFormat = "0.0"
'voeg grafiekgegevns toe
'ExcelCht.SetSourceData ExcelSht3.Range("D"), xlColumns
'zet grafiek in werkscherm
On Error Resume Next
'ExcelCht.ChartArea.Select
'ExcelCht.ChartArea.Copy
'Image2.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
Ik hoop dat iemand van jullie mij snel kan helpen
In ieder geval alvast bedankt.
Ik heb een programma gemaakt welke van drie COM-poorten de data inleest en doorvoert naar resp. ExcelSheet(1), ExcelSheet(2) en ExcelSheet(3).
Dit werkt op zich redelijk goed, alleen mijn opdracht om naar de volgende regel (Row) te gaan werkt voor alledrie de sheets tegelijk. Hierdoor krijg ik steeds lege regels er tussendoor in elk van de sheets.
Wie weet hoe ik de code zó kan maken dat ik in elke Sheet apart een regel kan toevoegen.
Ik heb nu gebruikt : ExcelRow = ExcelRow + 1 in elk van de On CommEvents van de poorten.
hier de code: ( kijk vooral bij Private Sub rs232_OnComm)
Option Explicit
Dim ExcelApp As Excel.Application
Dim ExcelCht As Excel.Chart
Dim ExcelSht1 As Excel.Worksheet
Dim ExcelSht2 As Excel.Worksheet
Dim ExcelSht3 As Excel.Worksheet
Dim ExcelWkb As Excel.Workbook
Dim MyExcel As Boolean
Dim ExcelRowActive As Integer
Dim ExcelColActive As Integer
Dim ExcelRow As Integer
Dim ExcelCol As Integer
Dim VolgNr1 As Integer
Dim VolgNr2 As Integer
Dim VolgNr3 As Integer
Dim Gemiddelde1 As Double
Dim Gemiddelde2 As Double
Dim Gemiddelde3 As Double
Dim Totaal1 As Double
Dim Totaal2 As Double
Dim Totaal3 As Double
Dim Buffer As Double
Dim Row, Col As Integer
Private Sub Command1_Click()
'schakel naar Exel
ExcelApp.Visible = True
End Sub
Private Sub Command2_Click()
cdlExample.ShowOpen
Shell "C:\Program Files\Microsoft Office\Office11\Excel.exe" & " " & cdlExample.FileName
End Sub
Private Sub Timer1_Timer()
Label4.Caption = Now
End Sub
Private Sub Form_Load()
Me.Show
DoEvents
VolgNr1 = 0
VolgNr2 = 0
VolgNr3 = 0
Totaal1 = 0
Totaal2 = 0
Totaal3 = 0
cdlExample.InitDir = "E:\" 'instelling Openfile menu
cdlExample.Filter = "Excel Docs (*.xls)|*.xls"
cdlExample.FileName = ""
On Error Resume Next
File1.FileName = "E:\*.xls"
'Excel openen en Sheets benoemen
On Error Resume Next
Err.Clear
Set ExcelApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Err.Clear
Set ExcelApp = CreateObject("Excel.Application")
If Err.Number <> 0 Then
MsgBox "Error: " & Err.Description
Else
MyExcel = True
End If
Else
MyExcel = False
End If
ExcelApp.Visible = True
Set ExcelWkb = ExcelApp.Workbooks.Add
Set ExcelSht1 = ExcelWkb.Worksheets(1)
Set ExcelSht2 = ExcelWkb.Worksheets(2)
Set ExcelSht3 = ExcelWkb.Worksheets(3)
ExcelSht1.Name = "Scale 1"
ExcelSht1.PageSetup.CenterHeader = "Results Scale 1" & " " & Date
ExcelSht1.PageSetup.PrintGridlines = True
ExcelSht2.Name = "Scale 2"
ExcelSht2.PageSetup.CenterHeader = "Results Scale 2" & " " & Date
ExcelSht2.PageSetup.PrintGridlines = True
ExcelSht3.Name = "Scale 3"
ExcelSht3.PageSetup.CenterHeader = "Results Scale 3" & " " & Date
ExcelSht3.PageSetup.PrintGridlines = True
'set actieve cel
ExcelRowActive = ExcelApp.ActiveCell.Row
ExcelColActive = ExcelApp.ActiveCell.Column
ExcelRow = ExcelRowActive
ExcelCol = ExcelColActive
'maak grafiek
Set ExcelCht = ExcelWkb.Charts.Add
ExcelCht.ChartType = xlLineMarkers
ExcelCht.HasTitle = True
ExcelCht.ChartTitle.Characters.Text = "3 Scales"
ExcelCht.Axes(xlCategory, xlPrimary).HasTitle = True
ExcelCht.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "X-Axis"
ExcelCht.Axes(xlValue, xlPrimary).HasTitle = True
ExcelCht.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Weight Scales"
ExcelCht.Name = "Chart All Scales"
With Selection.Border
.ColorIndex = 57
.Weight = xlThick
.LineStyle = xlContinuous
End With
Me.SetFocus
If rs232.PortOpen = True Then rs232.PortOpen = False
If rs232b.PortOpen = True Then rs232b.PortOpen = False
If rs232c.PortOpen = True Then rs232c.PortOpen = False
rs232.CommPort = 6
rs232.PortOpen = True
rs232.Settings = "9600,N,8,1"
rs232.CommEvent = 0
rs232b.CommPort = 7
rs232b.PortOpen = True
rs232b.Settings = "9600,N,8,1"
rs232b.CommEvent = 0
rs232c.CommPort = 9
rs232c.PortOpen = True
rs232c.Settings = "9600,N,8,1"
rs232c.CommEvent = 0
End Sub
Private Sub quitprogram_Click()
Dim fso As New FileSystemObject
Dim Drive As Drive
If fso.DriveExists("E:") Then
MsgBox ("USB stick is available !"), vbOKOnly 'Er is een floppy
Else: MsgBox ("put in the USB stick !"), vbOKOnly
' On Error Resume Next
'Set Drive = fso.GetDrive("E:")
End If
If MyExcel Then
ExcelApp.ActiveWorkbook.SaveAs "E:\" & Date & ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
Else: Exit Sub
ExcelApp.Quit
End If
End
End Sub
Private Sub rs232_OnComm():
VolgNr1 = VolgNr1 + 1
rs232.InputLen = 16
rs232.RThreshold = 16
Select Case rs232.CommEvent
' Handle each event or error by placing
Case comEvReceive ' Received RThreshold # of
' chars.
Text2 = Val(rs232.Input)
End Select
If Text2 = "0" Then 'Bij tarreren of 0g geen overdracht naar Excel
VolgNr1 = VolgNr1 - 1 'VolgNr1 terugzetten
Exit Sub
End If
On Error Resume Next
Totaal1 = Totaal1 + Text2
Gemiddelde1 = Totaal1 / VolgNr1
Text1.Text = Gemiddelde1
Text3.Text = VolgNr1
ExcelSht1.Cells(ExcelRow, ExcelCol) = VolgNr1
ExcelSht1.Cells(ExcelRow, ExcelCol + 1) = Format(Time, "h:mm:ss")
ExcelSht1.Cells(ExcelRow, ExcelCol + 2) = Text2
ExcelSht1.Cells(ExcelRow, ExcelCol + 3) = Gemiddelde1
ExcelSht1.Range("D
").NumberFormat = "0.0"'voeg grafiekgegevns toe
'ExcelCht.SetSourceData ExcelSht1.Range("D
"), xlColumnsExcelRow = VolgNr1 + 1
(De bovenstaande regel veroorzaakt in alledrie de sheets een extra regel, dit moet alleen in de eerste sheet zijn. En dan bij rs232b_OnComm de tweede sheet enz.)
'zet grafiek in werkscherm
On Error Resume Next
'ExcelCht.ChartArea.Select
'ExcelCht.ChartArea.Copy
'Image2.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
Private Sub rs232b_OnComm()
VolgNr2 = VolgNr2 + 1
rs232b.InputLen = 16
rs232b.RThreshold = 16
Select Case rs232b.CommEvent
' Handle each event or error by placing
Case comEvReceive ' Received RThreshold # of
' chars.
Text6 = Val(rs232b.Input)
End Select
If Text6 = "0" Then 'Bij tarreren of 0g geen overdracht naar Excel
VolgNr2 = VolgNr2 - 1 'VolgNr2 terugzetten
Exit Sub
End If
On Error Resume Next
Totaal2 = Totaal2 + Text6
Gemiddelde2 = Totaal2 / VolgNr2
Text5.Text = Gemiddelde2
Text4.Text = VolgNr2
ExcelSht2.Cells(ExcelRow, ExcelCol) = VolgNr2
ExcelSht2.Cells(ExcelRow, ExcelCol + 1) = Format(Time, "h:mm:ss")
ExcelSht2.Cells(ExcelRow, ExcelCol + 2) = Text6
ExcelSht2.Cells(ExcelRow, ExcelCol + 3) = Gemiddelde2
ExcelSht2.Range("D
").NumberFormat = "0.0"'voeg grafiekgegevns toe
'ExcelCht.SetSourceData ExcelSht2.Range("D
"), xlColumnsExcelRow = VolgNr2 + 1
'zet grafiek in werkscherm
On Error Resume Next
'ExcelCht.ChartArea.Select
'ExcelCht.ChartArea.Copy
'Image2.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
Private Sub rs232c_OnComm()
VolgNr3 = VolgNr3 + 1
rs232c.InputLen = 16
rs232c.RThreshold = 16
Select Case rs232c.CommEvent
' Handle each event or error by placing
Case comEvReceive ' Received RThreshold # of
' chars.
Text7 = Val(rs232c.Input)
End Select
If Text7 = "0" Then 'Bij tarreren of 0g geen overdracht naar Excel
VolgNr3 = VolgNr3 - 1 'VolgNr1 terugzetten
Exit Sub
End If
On Error Resume Next
Totaal3 = Totaal3 + Text7
Gemiddelde3 = Totaal3 / VolgNr3
Text8.Text = Gemiddelde3
Text9.Text = VolgNr3
ExcelApp.Sheets("Scale 3").Select
ExcelSht3.Cells(ExcelRow, ExcelCol) = VolgNr3
ExcelSht3.Cells(ExcelRow, ExcelCol + 1) = Format(Time, "h:mm:ss")
ExcelSht3.Cells(ExcelRow, ExcelCol + 2) = Text7
ExcelSht3.Cells(ExcelRow, ExcelCol + 3) = Gemiddelde3
ExcelSht3.Range("D
").NumberFormat = "0.0"'voeg grafiekgegevns toe
'ExcelCht.SetSourceData ExcelSht3.Range("D
"), xlColumns'zet grafiek in werkscherm
On Error Resume Next
'ExcelCht.ChartArea.Select
'ExcelCht.ChartArea.Copy
'Image2.Picture = Clipboard.GetData(vbCFBitmap)
End Sub
Ik hoop dat iemand van jullie mij snel kan helpen
In ieder geval alvast bedankt.
