Anfänger: Script zur Transformation von Fräskräften?

[Bruno]

Bei mir funktionert es, wenn ich mit der Variablen "ExcelExpSheetChn" arbeite, also
ExcelExpSheetChn = &FS&"_TV"&TVnr&"_radius"&re&
und vorher in der STP Datei 'Names des Blatts' gelöscht habe.
ABER: DIAdem überschreibt die Alte xls Datei!
Um eine vorhandene Datei abzuändern benötigst Du OLE...
Gruß
Bruno

[Bruno]

Code:

'-------------------------------------------------------------------------------
'-- VBS-Script-Datei
'-- Neu erstellt am 24.06.2010 08:44:10
'-- Ersteller:
'-- Kommentar:
'-------------------------------------------------------------------------------
Option Explicit  'Erzwingt die explizite Deklaration aller Variablen in einem Script.
Const DiademExcelWorkbook = "c:\Versuchsergebnisse.xls"
Const xlMaximized =&HFFFFEFD7
Dim Excel           ' Object variable for Excel
Dim myExcelSheet      ' Object variable for Excel worksheet

runExcel

Sub runExcel
  Dim DataCol       ' Data column
  Dim DataRow       ' Data row
  
  ' Disable automatic error handling to prevent error messages.
  On Error Resume Next
  
  ' Start Excel via OLE.
  ' A new Excel instance always starts.
  Set Excel = CreateObject("Excel.Application")
  If CheckError Then Exit Sub
  
  ' Show Excel. Excel was hidden up to now.
  Excel.Visible = True
  
  ' Maximize Excel window.
  Excel.WindowState = xlMaximized
  

  ' Open prepared DIAdem table in Excel.
  Excel.Workbooks.Open(DiademExcelWorkbook)
  
  ' Provide reference to DIAdem table.
  ' The reference makes it easier to access the table.
  Set myExcelSheet = Excel.Sheets.Add
  ' Select first cell in the worksheet.
  myExcelSheet.Name = "Test"
  myExcelSheet.Cells(1, 1).Select
  
  ' Display infomation text above the data table. The text is written
  ' in a cell. The '.Value' property must not necessarily be specified,
  ' because the default property is 'Cells'.
  ' Cells(1, 1) = "abc" means the same as Cells(1, 1).Value = "abc".
  myExcelSheet.Cells(1, 3).Value = "DIAdem steuert Excel an..."
  If CheckError Then Exit Sub
  
    If MsgBox("Excel schließen?", vbYesNo Or vbQuestion, "Bestätigen") = vbYes Then
      ' Set status of Excel work folder to saved, so no prompt
      ' appears when Excel closes.
      ExcelSheet.Parent.Saved = True
  
      ' In VBS, Excel must be closed explicitly.
      Excel.Quit
    End If
  
    ' Set object references to 'Nothing'.
    Set ExcelSheet = Nothing
    Set Excel = Nothing
  
    ' Restore DIAdem window.
    Call WndShow("SHELL", "NORMAL")
End sub

' ----------------------------------------------------------------------------------------
' Name:      CheckError
'
' Purpose:     Check error status and display message is necessary.
'
' Parameters: None
' ----------------------------------------------------------------------------------------
'Sub CheckError()
Function CheckError

  CheckError = False
  ' If error occurs.
  If Err.Number <> 0 Then
    CheckError = True
    ' Restore DIAdem window.
    Call WndShow("SHELL", "NORMAL")

    ' Display error message.
    Call MsgBoxDisp("Fehler bei OLE-Kommunikation!" & vbCrLf & _
                    "Fehlernummer: "& CStr(Err.Number) & vbCrLf _
                    & Err.Description & vbCrLf & vbCrLf _
                    & "DIAdem bricht das Script ab!", , "MsgTypeAlert")

    ' Reset error status.
    Err.Clear
  End If

End Function

Hier mal ne abgespeckte Version von Expl_OLE.vbs, mit der Du starten kannst.
Gruß
Bruno

[M.Schneiders]

(24.06.2010 08:44)Bruno schrieb:  Hier mal ne abgespeckte Version von Expl_OLE.vbs, mit der Du starten kannst.
Gruß
Bruno

Hallo Bruno,
danke, das habe ich schon länger auf meiner ToDo stehen gehabt.

Gruß
M.Schneiders

[Rednaxela]

Hi!

Danke auch von mir!!!!

Probiere am Wochenende wieder rum! Melde mich dann!

Grüße und nochmal vielen Dank!
Alex

[Rednaxela]

Hi!
Dein Script funktioniert soweit! Nochmal danke! Auch, dass ein neues Tabellenblatt erstellt wird, aus zuvor eingegebenen Variablen, hab ich hinbekommen

Jetzt häng ich gerade beim übertragen meiner Kanäle. Angenommen ich habe folgende Kanäle:
- [1]/Fv
- [1]/Fvn
- [1]/Fz
- [1]/Result XY
- [1]/CopyYFv
- [1]/CopyYFvn
- [1]/CopyYFz
- [1]/CopyYResult XY

Ich will aber nur folgende in "Versuchsergebnisse.xls" übertragen:
- [1]/CopyYFv
- [1]/CopyYFvn
- [1]/CopyYFz
- [1]/CopyYResult XY

Wie programmiert man das im Script? Aus dem OLE-Beispiel werd ich nicht ganz schlau:
....
myExcelSheet.Cells(1, 3).Value = "Ergebnisse"
If CheckError Then Exit Sub

' Set column headings in the data table.
ExcelSheet.Cells(2, 1).Value = "CopyYFv"
If CheckError Then Exit Sub
ExcelSheet.Cells(2, 2).Value = "CopyYFvn"
If CheckError Then Exit Sub
ExcelSheet.Cells(2, 3).Value = "CopyYFz"
If CheckError Then Exit Sub
ExcelSheet.Cells(2, 4).Value = "CopyYResult XY"
If CheckError Then Exit Sub

' Disable screen refresh.
Excel.ScreenUpdating = False

' Transfer single data columnwise and rowwise.
For DataCol = 5 To 8
ExcelSheet.Cells(DataCol-4, 2).Value = ChnVal("[1]/", DataCol)
Next
If CheckError Then Exit Sub

' Enable screen refresh.
Excel.ScreenUpdating = True
.....

Das will irgendwie nicht klappen, wo ist der Fehler?

Grüße!

[Rednaxela]

UPDATE:

Hi Bruno!
Hab den Excel-Transfer jetzt mehr oder weniger so hinbekommen, wie ich es haben will:

Code:

Option Explicit  'Erzwingt die explizite Deklaration aller Variablen in einem Script.
Dim Antwort
Antwort = msgbox("Excel-Export der Ergebnisse gewünscht?", vbYesNo)

if Antwort = vbYes then
    'Excel export
    Const DiademExcelWorkbook = "C:\Dokumente und Einstellungen\Administrator\Desktop\Script Alex Selfmade\Excel-Exporte\Versuchsergebnisse.xls"
    Call DataMatrixToExcel()
'-------------------------------------------------------------------------------
' DataMatrixToExcel
' Diese Prozedur uebertraegt die Daten aus der Datenmatrix an Excel.
' Dazu wird Excel als Apllikation gestartet und die Daten werden über die
' Active-X Schnittstelle von Excel übertragen
'-------------------------------------------------------------------------------
Sub DataMatrixToExcel
  Dim oExcel,oWorkbookT,oSheetT,iChannelT,lFirstDataRowT,lChnCountT,lLengthT,lProzent,​ iIndex1, iIndex2
  '-------------------------------------------------
  ' Excel als Applikation starten :
  '-------------------------------------------------
  Set oExcel = CreateObject("Excel.Application")
  ' Erste Zeile mit Daten :
  lFirstDataRowT = 6
  ' Open prepared DIAdem table in Excel.
  Set oWorkbookT = oExcel.Workbooks.Open(DiademExcelWorkbook)
  'Sheet in Excel anlegen
  Set oSheetT = oWorkbookT.Sheets.Add
  ' Kanaele zaehlen
  lChnCountT = 0
  For iChannelT = 1 To ChnNoMax
    if ( 0 >= Len(ChnName(iChannelT)) ) Then Exit For
    lChnCountT = lChnCountT + 1
  Next
  ' Namen des Tabellenblatts setzen in das die DIAdem-Daten eingetragen werden
  oSheetT.Name = FS & "_TV" & TVnr & "_Vc" & Vc & "_r" & re & "_p" & p & "_fz" & fz
  
  '-------------------------------------------------
  ' Informationen aus dem Kanalheader uebertragen :
  '-------------------------------------------------
  For iChannelT = 1 To lChnCountT
    oSheetT.Cells(1, iChannelT) = ChnName(iChannelT)
    oSheetT.Cells(2, iChannelT) = ChnComment(iChannelT)
    oSheetT.Cells(3, iChannelT) = ChnDim(iChannelT)
    oSheetT.Cells(4, iChannelT) = ChnLength(iChannelT)
    ' Noch was fuers Auge ....
    oSheetT.Cells(5, iChannelT).Interior.ColorIndex = 48
    oSheetT.Columns(iChannelT).AutoFit
  Next
  '-------------------------------------------------
  ' Kanaldaten übertragen
  '-------------------------------------------------
  For iChannelT = 5 To lChnCountT
    Call LoopInit()
    Call MsgLineDisp("Übertragung des Kanals '"&ChnName(iChannelT)&"' ("&CStr(ChnLength(iChannelT))&" Werte)")
    ' ----- ist ein NV-Wert im Kanal ?
    if ucase(ChnNovKey(iChannelT)) = "YES" then
      For iIndex1 = 1 To ChnLength(iChannelT)
        oSheetT.Cells(lFirstDataRowT+iIndex1-1, iChannelT) = GetValue(iIndex1,iChannelT)
        lProzent = (iIndex1*100)/ChnLength(iChannelT)
        If ( 0 = (lProzent Mod 5 ) ) Then Call LoopInc(lProzent)
      Next
    else
      For iIndex2 = 1 To ChnLength(iChannelT)
        oSheetT.Cells(lFirstDataRowT+iIndex2-1, iChannelT) = GetValueX(iIndex2,iChannelT)
        lProzent = (iIndex2*100)/ChnLength(iChannelT)
        If ( 0 = (lProzent Mod 5 ) ) Then Call LoopInc(lProzent)
      Next
    end if
    Call LoopDeInit()
  Next
  ' Excel anzeigen
  oExcel.Visible = true
  If MsgBox("Excel schließen?", vbYesNo Or vbQuestion, "Bestätigen") = vbYes Then
      ' Set status of Excel work folder to saved, so no prompt appears when Excel closes.
      oSheetT.Parent.Saved = True
  
      ' In VBS, Excel must be closed explicitly.
      oExcel.Quit
    End If
  
    ' Set object references to 'Nothing'.
    Set oSheetT = Nothing
    Set oExcel = Nothing
  
End Sub

' ----- holt Werte und prüft nicht auf NV
function GetValueX(iIdxT, iChnT)
  GetValueX = CHD(iIdxT,iChnT)
end function

' ----- holt Werte und prüft auf NV
function GetValue(iIdxT, iChnT)
dim vVal
  vVal = CHD(iIdxT,iChnT)
  if IsNull(vVal) then
    GetValue = "Novalue"
  else
    GetValue = vVal
  end if    
end function
  
Else
  MsgBox "Das Script wurde beendet!"
  AutoQuit()
End If

Nur wenn ich Excel dann per Script schließen lasse, werden meine exportierten Ergebnisse nicht automatisch abgespeichert. D.h., an folgender Stelle im obigen Code muss irgendwo ein Fehler sein:

Code:

If MsgBox("Excel schließen?", vbYesNo Or vbQuestion, "Bestätigen") = vbYes Then
      ' Set status of Excel work folder to saved, so no prompt appears when Excel closes.
      oSheetT.Parent.Saved = True
  
      ' In VBS, Excel must be closed explicitly.
      oExcel.Quit
    End If
  
    ' Set object references to 'Nothing'.
    Set oSheetT = Nothing
    Set oExcel = Nothing

Siehst Du den Fehler zufällig?

Viele Grüße,
Alex

[Bruno]

Hallo Alex,
schön, dass es soweit klappt!
Du hast ja die richtige Stelle im Code schon gefunden: In meinem Codebeispiel, welches ich aus Dem Diadembeispiel herausgenommen habe, wird Excel vorgespielt, dass die Daten bereits gespeichert sind (siehe auch die Kommentarzeile)

Code:

' Set status of Excel work folder to saved, so no prompt
' appears when Excel closes.
oSheetT.Parent.Saved = True

Das muss natürlich weg!
Automatisch speichern wäre:

Code:

Excel.ActiveWorkbook.Save

Gruß
Bruno

[Rednaxela]

Hey Bruno!
DANKE! Es klappt alles! Wirklich super! Ohne deine Hilfe hätte ich das nicht hinbekommen!

Noch eine letzte Kleinigkeit:

Zum Abschluss will ich die aktuelle "Default-Datei" im Datenportal abspeichern. Ich benutze folgenden Code, welcher auch funktioniert!

Code:

Dim Speichern1
Speichern1 = msgbox("Die aktuell im Datenportal verwendete Datei abspeichern unter ...\Auswertung\ ?", vbYesNo)
    if Speichern1 = vbYes then
        'Speichert den gesamten Datenbestand des DIAdem-Datenportals mit den zugehörigen Eigenschaften in einer Datendatei.
        Call DATAFILESAVE(AutoActPath & "\Auswertung\ & TEST & "_TV" & TVnr & "_fz" & fz &".tdm", "TDM")            
    else
        AutoQuit()
    end If

Nur würde ich gerne wissen, wie ich es hinbekomme, dass an der Stelle "TEST" automatisch der Name der aktuellen Default-Datei eingesetzt wird? Da gibt es doch bestimmt auch nen Befehl, oder?

Grüße!

[Rednaxela]

UPDATE:

Hab das letzte Problem soeben gelöst Folgender Code:

Code:

Dim Speichern1
Dim Gruppenname1
Gruppenname1 = ChnPropGet("[1]/Fv", "sourcedatafilename")
Speichern1 = msgbox("Die aktuell im Datenportal verwendete Datei abspeichern unter ...\Auswertung\ ?", vbYesNo)
    if Speichern1 = vbYes then
        Call DATAFILESAVE(AutoActPath & "\Auswertung\" & Gruppenname1 & "_TV" & TVnr & "_fz" & fz & ".tdm", "TDM")            'Speichert den gesamten Datenbestand des DIAdem-Datenportals mit den zugehörigen Eigenschaften in einer Datendatei.
    else
        AutoQuit()
    end If

Nur leider gibt er als Dateiname dann Folgendes aus:
"sp_kraft2_vc200_fvar_r04_p05_1.TDM_TV1.1_fz0,1.tdm"

Geht es auch so, dass "TDM" in der Mitte weggelassen wird? Also, dass "tdm" ausschließlich am Ende steht?

Grüße!

[Bruno]

Hallo Alex,
schön, dass das Programieren schon so gut klappt
Ich kann nicht genau sehen, in welcher Variablen der Dateiname mit der Endung TDM steckt, ich vermute es ist "Gruppenname1"?
Mit der Funktion FileNameSplit kannst Du die Dateinamenserweiterung abschneiden:

Code:

NameSplit(Gruppenname1,"N")

Müsstest Du noch an entsprechender Stelle in Deinen Code einbauen...
Gruß
Bruno