( http://www.purebasic.fr/german/viewtopi ... disphelper )
und der Hilfe von Kiffi und ts-soft soweit zusammenstellen konnte.
Ich will noch anmerken, das Kiffi und ts-soft mir hierbei eine sehr
große Hilfe waren. Also hier nochmals, vielen Dank für eure Unterstützung.
Und nun der Demosource, der aber nur auf Rechnern läuft wo auch
Excel vorhanden ist.
Grüße ...Falko
Code: Alles auswählen
;Autor Falko
;Danke an Kiffi und ts-soft, die mir hierbei geholfen haben
;das ich mittels 'PureDisphelper' und den vielen Tips zu VB/A
;diesen Source hier anbieten kann.
;Natürlich gilt mein Dank auch an mk-soft und schic :)
;Für weitere Funktionen, die hier dazu gekommen sind, gilt mein Dank
;an mueckerich für das SaveWorkbookAs().
EnableExplicit
Define.l Pattern, ExcelAPP, Sheets, SheetN, n, AnfangX, AnfangY, EndeX, EndeY
Define.s StandardFile, sPattern, Datei, StandardFile, Text
#xlAscending = 1
#xlContinuous = 1
#xlCenter = -4108
#xlSolid=1
#xlContinuous=1
#xlThin=2
#xlNone=-4142
#xlWorksheet=-4167
#xlDouble = -4119
#xlDash = -4115
#xlDashDot = 4
#xlDashDotDot = 5
#xlDot = -4118
#xlDouble = -4119
#xlAutomatic = -4105
#xlLineStyleNone = -4142
#xlSlantDashDot = 13
#xlHairline = 1
#xlMedium = -4138
#xlThick = 4
#xlDiagonalDown = 5
#xlDiagonalUp = 6
#xlEdgeBottom = 9
#xlEdgeLeft = 7
#xlEdgeRight = 10
#xlEdgeTop = 8
#xlInsideHorizontal = 12
#xlInsideVertical = 11
#xlFormatFromLeftOrAbove = 0
#xlFormatFromRightOrBelow = 1
#xlToolbar = 1
#xlToolbarButton = 2
#xlToolbarProtectionNone = -4143
#xlTop = -4160
#xlTop10Items = 3
#xlTop10Percent = 5
#xlTopToBottom = 1
#xlToRight = -4161
#xlToLeft = -4159
#xlUp = -4162
#xlDown = -4121
#xlLightUp = 14
#xlPatternAutomatic = -4105
#xlPatternChecker = 9
#xlPatternCrissCross = 16
#xlPatternDown = -4121
#xlPatternGray16 = 17
#xlPatternGray25 = -4124
#xlPatternGray50 = -4125
#xlPatternGray75 = -4126
#xlPatternGray8 = 18
#xlPatternGrid = 15
#xlPatternHorizontal = -4128
#xlPatternLightDown = 13
#xlPatternLightHorizontal = 11
#xlPatternLightUp = 14
#xlPatternLightVertical = 12
#xlPatternLinearGradient = 4000
#xlPatternNone = -4142
#xlPatternRectangularGradient = 4001
#xlPatternSemiGray75 = 10
#xlPatternSolid = 1
#xlPatternUp = -4162
#xlPatternVertical = -4166
XIncludeFile "F:\PureBasic_4\Examples\DispHelper_Include\VariantHelper_Include.pb" ; write here your VariantHelper_include.pb - path
Procedure OpenExcelFile(Datei.s)
Protected *obj
dhToggleExceptions(#True); Toggles error messages from DispHelper on or off
*obj = dhCreateObject("Excel.Application")
If *obj
dhCallMethod(*obj, ".Workbooks.Open(%T)", @Datei) ; open ExcelFile
EndIf
ProcedureReturn *obj
EndProcedure
Procedure OpenExcelFileNext(*obj,Datei.s)
;dhToggleExceptions(#True); Toggles error messages from DispHelper on or off
;*obj = dhCreateObject("Excel.Application")
If *obj
dhCallMethod(*obj, ".Workbooks.Open(%T)", @Datei) ; open ExcelFile
EndIf
ProcedureReturn *obj
EndProcedure
Procedure ExcelVisible(*obj,Wert.l)
If Wert=1
dhPutValue(*obj, ".Visible = %b", #True) ; Visible Excel
Else
dhPutValue(*obj, ".Visible = %b", #False) ; Non visible Excel
EndIf
EndProcedure
Procedure.s ReadCellS(*obj, Zeile.l,Spalte.l)
Protected ReturnValue.l, Resume.s
dhGetValue("%T", @ReturnValue, *obj, "Cells(%d, %d).Value",Zeile, Spalte) ; read one value
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
EndProcedure
Procedure WriteCellS(*obj, Zeile.l, Spalte.l, NewValue.s)
dhPutValue(*obj, "Cells(%d, %d).Value = %T", Zeile, Spalte, @NewValue) ; write one valuew
EndProcedure
Procedure WriteCellZ(*obj, Zeile.l, Spalte.l, NewValueZ.d)
dhPutValue(*obj, "Cells(%d, %d).Value = %e", Zeile, Spalte, @NewValueZ) ; write one value
EndProcedure
Procedure.s ReadLeftHeader(*obj)
Protected ReturnValue.l, Resume.s
dhGetValue("%T", @ReturnValue, *obj, ".ActiveSheet.PageSetup.LeftHeader") ; read left header
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
EndProcedure
Procedure.s ReadCenterHeader(*obj)
Protected ReturnValue.l, Resume.s
dhGetValue("%T", @ReturnValue, *obj, ".ActiveSheet.PageSetup.CenterHeader") ; read center header
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
EndProcedure
Procedure.s ReadRightHeader(*obj)
Protected ReturnValue.l, Resume.s
dhGetValue("%T", @ReturnValue, *obj, ".ActiveSheet.PageSetup.RightHeader"); read right header
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
EndProcedure
Procedure.s ReadLeftFooter(*obj)
Protected ReturnValue.l, Resume.s
dhGetValue("%T", @ReturnValue, *obj, ".ActiveSheet.PageSetup.LeftFooter"); read left footer
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
EndProcedure
Procedure.s ReadCenterFooter(*obj)
Protected ReturnValue.l, Resume.s
dhGetValue("%T", @ReturnValue, *obj, ".ActiveSheet.PageSetup.CenterFooter"); read center footer
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
EndProcedure
Procedure.s ReadRightFooter(*obj)
Protected ReturnValue.l, Resume.s
dhGetValue("%T", @ReturnValue, *obj, ".ActiveSheet.PageSetup.RightFooter"); read right footer
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
EndProcedure
Procedure WriteLeftHeader(*obj, Text.s)
dhPutValue(*obj, ".ActiveSheet.PageSetup.LeftHeader=%T", @Text) ; write left header
EndProcedure
Procedure WriteCenterHeader(*obj, Text.s)
dhPutValue(*obj, ".ActiveSheet.PageSetup.CenterHeader=%T", @Text); write center header
EndProcedure
Procedure WriteRightHeader(*obj, Text.s)
dhPutValue(*obj, ".ActiveSheet.PageSetup.RightHeader=%T", @Text); write right header
EndProcedure
Procedure WriteLeftFooter(*obj, Text.s)
dhPutValue(*obj, ".ActiveSheet.PageSetup.LeftFooter=%T", @Text);write left footer
EndProcedure
Procedure WriteCenterFooter(*obj, Text.s)
dhPutValue(*obj, ".ActiveSheet.PageSetup.CenterFooter=%T", @Text); write center footer
EndProcedure
Procedure WriteRightFooter(*obj, Text.s)
dhPutValue(*obj, ".ActiveSheet.PageSetup.RightFooter=%T", @Text) ; write right footer
EndProcedure
Procedure DisplayAlertsOnOff(*obj,Wert.l)
If Wert=1
dhPutValue(*obj, ".Application.DisplayAlerts = %b", #True) ; alerts on
ElseIf Wert=0
dhPutValue(*obj, ".Application.DisplayAlerts = %b", #False) ; alerts off
EndIf
EndProcedure
Procedure CloseExcelAll(*obj)
dhCallMethod(*obj, ".Quit"); Close Excel
dhReleaseObject(*obj):*obj = 0
EndProcedure
Procedure CloseWorkbook(*obj)
Protected Workbook.l
dhGetValue("%o", @Workbook, *obj, ".ActiveWorkbook")
If Workbook
dhCallMethod(Workbook, ".Close"); close Excel Worksheet
dhReleaseObject(Workbook)
EndIf
EndProcedure
Procedure SaveWorkbook(*obj)
Protected Workbook.l
dhGetValue("%o", @Workbook, *obj, ".ActiveWorkbook")
If Workbook
dhCallMethod(Workbook, ".Save"); Save Excel Workbook
dhReleaseObject(Workbook)
EndIf
EndProcedure
Procedure WriteToWorksheet(*obj,Name.s,Zeile.l, Spalte.l, NewValue.s)
dhPutValue(*obj, "Worksheets(%T).Cells(%d,%d).Value = %T", @Name, Zeile, Spalte, @NewValue); Write to Worksheets
EndProcedure
Procedure ChangeToWorksheet(*obj,Name.s); Change worksheet
dhCallMethod(*obj,"Worksheets(%T).Select",@Name)
EndProcedure
Procedure.s GetSheetName(*obj,Num.l)
Protected ReturnValue.l, Resume.s
dhToggleExceptions(#False)
dhGetValue("%T", @ReturnValue, *obj, "Worksheets(%d).Name",Num); Read Worksheetnames
If ReturnValue
Resume=PeekS(ReturnValue)
dhFreeString(ReturnValue)
ProcedureReturn Resume
EndIf
dhToggleExceptions(#True)
EndProcedure
Procedure.l CountSheets(*obj) ; Counting all Sheets
Protected ReturnValue.l
dhGetValue("%d", @ReturnValue, *obj,"Worksheets.Count")
ProcedureReturn ReturnValue
EndProcedure
Procedure AddWorksheetBefore(*obj)
dhCallMethod(*obj,"Worksheets.Add");Adds new worksheet For the first worksheet
EndProcedure
Procedure AddWorksheetAfter(*obj)
Protected Sheets.l, n.l,SheetN.l
dhGetValue("%o", @Sheets, *obj, ".Sheets") ;Sheets = Sheets-Auflistungsobjekt
dhGetValue("%d", @n, *obj, ".WorkSheets.Count") ; Count-Eigenschaft, n = Rückgabewert = Anzahl der xl-Blätter
dhGetValue("%o", @SheetN, *obj, ".WorkSheets(%d)",n); SheetN = Worksheets(n)
dhCallMethod(Sheets, ".Add(%m ,%o,%d,%d)",SheetN,1,#xlWorksheet)
EndProcedure
Procedure RenameActiveSheet(*obj,Name.s)
dhPutValue(*obj,"ActiveSheet.Name(%T)",@Name);Rename Sheetname to the active Worksheet
EndProcedure
Procedure SaveWorkbookAs(*obj, FileName.s)
Protected Workbook.l
dhGetValue("%o", @Workbook, *obj, ".ActiveWorkbook")
If FileName <> ""
If Workbook
dhCallMethod(Workbook, ".Saveas=%T" ,@FileName); Save Excel Workbook as
dhReleaseObject(Workbook)
EndIf
EndIf
EndProcedure
;--Vielen Dank, @Kiffi
Procedure SetColor(*obj, RangeStart.s, RangeEnd.s, cRed.l, cGreen.l, cBlue.l); Set color in Cells
Protected Range.s = RangeStart + ":" + RangeEnd
dhCallMethod(*obj, ".Range(%T).Select", @Range)
dhPutValue (*obj, ".Selection.Interior.Color = %d", RGB(cRed, cGreen, cBlue))
dhPutValue (*obj, ".Selection.Interior.Pattern = %d", #xlSolid)
EndProcedure
Procedure ColorOff(*obj, RangeStart.s, RangeEnd.s); Erase color in Cells
Protected Range.s = RangeStart + ":" + RangeEnd
dhCallMethod(*obj, ".Range(%T).Select", @Range)
dhPutValue (*obj, ".Selection.Interior.Pattern = %d", #xlNone)
EndProcedure
Procedure LinienEinAus(*obj) ; Skip the lines on or off
Protected LineStyle.VARIANT
dhGetValue("%v", @LineStyle, *obj, ".Selection.Borders.LineStyle")
If VT_LONG(LineStyle) = #xlNone
V_LONG(LineStyle) = #xlContinuous
Else
V_LONG(LineStyle) = #xlNone
EndIf
dhPutValue(*obj, ".Selection.Borders.LineStyle = %v", LineStyle)
EndProcedure
Procedure RechtsMarkieren(*obj); here a Demo to mark cells reight from select Cells
Protected Range1.l, Range2.l
dhGetValue("%o", @Range1, *obj, ".ActiveCell.Offset(%d,%d)", 0, 1)
If Range1
dhGetValue("%o", @Range2, *obj, ".ActiveCell.Offset(%d,%d)", 0, 3)
If Range2
dhCallMethod(*obj, ".Range(%o, %o).Select", Range1, Range2)
dhReleaseObject(Range2)
EndIf
dhReleaseObject(Range1)
EndIf
EndProcedure
;-- Ende, @Kiffi ;)
Procedure MarkCells(*obj, RangeStart.s, RangeEnd.s); mark Cells
Protected Range.s = RangeStart + ":" + RangeEnd
dhCallMethod(*obj, ".Range(%T).Select", @Range)
EndProcedure
Procedure AskToUpdateLinks(*obj,Wert.l)
If Wert=1
dhPutValue(*obj, ".AskToUpdateLinks = %b", #True) ; AskToUpdateLinks on
ElseIf Wert=0
dhPutValue(*obj, ".AskToUpdateLinks = %b", #False) ; AskToUpdateLinks off
EndIf
EndProcedure
;Mit Hilfe von Kiffi habe ich noch folgende Proceduren Set / Erase Borders zusammengebastelt :)
; Set Bit to LineStyle on Variable Wert
; Bit 1 set DiagonalDown
; Bit 2 set DiagonalUp
; Bit 3 set EdgeLeft
; Bit 4 set EdgeTop
; Bit 5 set EdgeBottom
; Bit 6 set EdgeRight
; Bit 7 set InsideVertical
; Bit 8 set InsideHorizontal
Procedure SetBorders(*obj, RangeStart.s, RangeEnd.s,NBorder.l,NLineStyles.l,ColorIndex.l) ; create a border, Tip from Kiffi
; for LineThick : #xlNone, #xlHairline, #xlMedium or #xlThick
Protected Range.s = RangeStart + ":" + RangeEnd
dhCallMethod(*obj, ".Range(%T).Select", @Range)
If NBorder & 1
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlDiagonalDown, NLineStyles)
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d",#xlDiagonalDown, ColorIndex)
EndIf
If NBorder & 2
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlDiagonalUp, NLineStyles)
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d",#xlDiagonalUp, ColorIndex)
EndIf
If NBorder & 4
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeLeft, #xlContinuous)
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d", #xlEdgeLeft, ColorIndex)
; dhPutValue (*obj, ".Selection.Borders(%d).TintAndShade = %d", #xlEdgeLeft, 0)
dhPutValue (*obj, ".Selection.Borders(%d).Weight = %d", #xlEdgeLeft, NLineStyles)
EndIf
If NBorder & 8
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeTop, #xlContinuous)
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d", #xlEdgeTop, ColorIndex)
; dhPutValue (*obj, ".Selection.Borders(%d).TintAndShade = %d", #xlEdgeTop, 0)
dhPutValue (*obj, ".Selection.Borders(%d).Weight = %d", #xlEdgeTop, NLineStyles)
EndIf
If NBorder & 16
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeBottom, #xlContinuous)
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d", #xlEdgeBottom, ColorIndex)
; dhPutValue (*obj, ".Selection.Borders(%d).TintAndShade = %d", #xlEdgeBottom, 0)
dhPutValue (*obj, ".Selection.Borders(%d).Weight = %d", #xlEdgeBottom, NLineStyles)
EndIf
If NBorder & 32
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeRight, #xlContinuous)
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d", #xlEdgeRight, ColorIndex)
; dhPutValue (*obj,".Selection.Borders(%d).TintAndShade = %d", #xlEdgeRight, 0)
dhPutValue (*obj, ".Selection.Borders(%d).Weight = %d", #xlEdgeRight, NLineStyles)
EndIf
If NBorder & 64
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d",#xlInsideVertical, ColorIndex)
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlInsideVertical, NLineStyles)
EndIf
If NBorder & 128
dhPutValue (*obj, ".Selection.Borders(%d).ColorIndex = %d",#xlInsideHorizontal, ColorIndex)
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlInsideHorizontal, NLineStyles)
EndIf
EndProcedure
Procedure EraseBorders(*obj, RangeStart.s, RangeEnd.s,NBorder.l) ; Erase a borders
Protected Range.s = RangeStart + ":" + RangeEnd
dhCallMethod(*obj, ".Range(%T).Select", @Range)
If NBorder & 1
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlDiagonalDown, #xlNone)
EndIf
If NBorder & 2
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlDiagonalUp, #xlNone)
EndIf
If NBorder & 4
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeLeft, #xlLineStyleNone)
EndIf
If NBorder & 8
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeTop, #xlLineStyleNone)
EndIf
If NBorder & 16
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeBottom, #xlLineStyleNone)
EndIf
If NBorder & 32
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlEdgeRight, #xlLineStyleNone)
EndIf
If NBorder & 64
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlInsideVertical, #xlNone)
EndIf
If NBorder & 128
dhPutValue (*obj, ".Selection.Borders(%d).LineStyle = %d", #xlInsideHorizontal, #xlNone)
EndIf
EndProcedure
Procedure MergeCells(*obj, RangeStart.s, RangeEnd.s,Wert.l) ; merge or unmerge Cells
Protected Range.s = RangeStart + ":" + RangeEnd
dhCallMethod(*obj, ".Range(%T).Select", @Range)
If Wert=1
dhCallMethod(*obj, ".Selection.Merge")
EndIf
If Wert=0
dhCallMethod(*obj, ".Selection.UnMerge")
EndIf
EndProcedure
Procedure InsertRow(*obj,Cell.s,Wert.b) ; insert or delete Row
dhCallMethod(*obj, "Range(%T).Select",@Cell)
If Wert=1
dhCallMethod(*obj,"Selection.EntireRow.Insert")
ElseIf Wert=0
dhCallMethod(*obj,"Selection.EntireRow.Delete")
EndIf
EndProcedure
Procedure InsertColumn(*obj,Cell.s,Wert.b); insert or delete Column
dhCallMethod(*obj, "Range(%T).Select",@Cell)
If Wert=1
dhCallMethod(*obj,"Selection.EntireColumn.Insert")
ElseIf Wert=0
dhCallMethod(*obj,"Selection.EntireColumn.Delete")
EndIf
EndProcedure
Procedure InsertCell(*obj,Cell.s,Wert.b) ;Insert Cells and shift right Or down
dhCallMethod(*obj, "Range(%T).Select",@Cell)
If Wert=1
dhCallMethod(*obj,"Selection.Insert Shift:= %d",#xlToRight)
ElseIf Wert=0
dhCallMethod(*obj,"Selection.Insert Shift:= %d",#xlDown)
EndIf
EndProcedure
Procedure DeleteCell(*obj,Cell.s,Wert.b) ;Delete Cells and shift left Or up
dhCallMethod(*obj, "Range(%T).Select",@Cell)
If Wert=1
dhCallMethod(*obj,"Selection.Delete Shift:= %d",#xlToLeft)
ElseIf Wert=0
dhCallMethod(*obj,"Selection.Delete Shift:= %d",#xlUp)
EndIf
EndProcedure
Procedure Pattern(*obj,Cell.s,Pattern.l,PatternColor.l,OnOff.b) ; PatternColor=RGB()
Protected pat.l
dhCallMethod(*obj, "Range(%T).Select",@Cell)
Select Pattern
Case 1
pat = #xlPatternAutomatic
Case 2
pat = #xlPatternChecker
Case 3
pat = #xlPatternCrissCross
Case 4
pat = #xlPatternDown
Case 5
pat = #xlPatternGray16
Case 6
pat = #xlPatternGray25
Case 7
pat = #xlPatternGray50
Case 8
pat = #xlPatternGray75
Case 9
pat = #xlPatternGray8
Case 10
pat = #xlPatternGrid
Case 11
pat = #xlPatternHorizontal
Case 12
pat = #xlPatternLightDown
Case 13
pat = #xlPatternLightHorizontal
Case 14
pat = #xlPatternLightUp
Case 15
pat = #xlPatternSemiGray75
Case 16
pat = #xlPatternSolid
Case 17
pat = #xlPatternUp
Case 18
pat = #xlPatternVertical
EndSelect
If OnOff=#True
dhPutValue(*obj,".Selection.Interior.PatternColor = %d",PatternColor)
dhPutValue(*obj,".Selection.Interior.Pattern = %d",pat)
ElseIf OnOff=#False
dhPutValue(*obj,".Selection.Interior.PatternColor = %d",#xlAutomatic)
dhPutValue (*obj, ".Selection.Interior.Pattern = %d", #xlNone)
EndIf
EndProcedure
;-- Main Program
Define.l i
Define.s Name
StandardFile = ""
sPattern = "Text (*.xls)|*.xls|Alle Dateien (*.*)|*.*"
Pattern = 0
Datei = OpenFileRequester("Bitte eine XLS-Datei auswählen", StandardFile, sPattern, Pattern)
dhToggleExceptions(#True); Toggles error messages from DispHelper on or off
ExcelApp=OpenExcelFile(Datei.s)
If ExcelApp
ExcelVisible(ExcelApp,1)
AskToUpdateLinks(ExcelApp,0) ; Non Ask to UpdateLinks
DisplayAlertsOnOff(ExcelApp,0) ; Excel Alerts off
MessageRequester("Read_Cells", ReadCellS(ExcelApp, 2, 1))
WriteCellS(ExcelApp, 1, 1, "Hier mein eigener Text")
WriteCellZ(ExcelApp, 1, 7, 20.56)
SaveWorkbook(ExcelApp)
Text = "Linke Kopfzeile: " + ReadLeftHeader(ExcelApp) + #CRLF$
Text + "Mittlere Kopfzeile: " + ReadCenterHeader(ExcelApp) + #CRLF$
Text + "Rechte Kopfzeile: " + ReadRightHeader(ExcelApp) + #CRLF$
Text + "Linke Fußzeile: " + ReadLeftFooter(ExcelApp) + #CRLF$
Text + "Mittlere Fußzeile: " + ReadCenterFooter(ExcelApp) + #CRLF$
Text + "Rechte Fußzeile: " + ReadRightFooter(ExcelApp)
MessageRequester("Excel_Kopf&Fusszeile", Text)
ExcelVisible(ExcelApp,1)
AddWorksheetBefore(ExcelApp); set new Sheet before
AddWorksheetAfter(ExcelApp); set new Sheet after
RenameActiveSheet(ExcelApp,"MyNewSheet");Write another name of worksheet
RechtsMarkieren(ExcelApp)
MessageRequester("Guck!", "Zellen sind rechts markiert")
SetColor(ExcelApp, "A1", "C6", 0, 255, 0)
MessageRequester("Guck!", "Alles so schön grün")
LinienEinAus(ExcelApp)
MessageRequester("Guck!", "Jetzt sind die Linien an")
LinienEinAus(ExcelApp)
MessageRequester("Guck!", "Jetzt sind die Linien aus")
ColorOff(ExcelApp, "A1", "C6")
MessageRequester("Guck!", "Und nun ist die grüne Farbe weg")
MarkCells(ExcelApp, "D1","G6")
MessageRequester("Guck!", "jetzt sind sind Cellen nach Wunsch markiert")
SetBorders(ExcelApp, "B2", "H5",%00111100, #xlThick,0);
MessageRequester("Guck!", "Die Zellen haben jetzt einen Rahmen")
SetBorders(ExcelApp, "B2", "H5",%11000000, #xlHairline,5)
MessageRequester("Guck!", "Die Zellen mit horizontalen und vertikalen dünnen Linien")
EraseBorders(ExcelApp, "B2", "H5",%11000011)
MessageRequester("Guck!", "Jetzt sind die dünnen Linien wieder")
InsertCell(ExcelApp,"D3",#True)
MessageRequester("Guck!", "Eine Zelle einfügen und nach rechts verschieben")
InsertCell(ExcelApp,"D3",#False)
MessageRequester("Guck!", "Eine Zelle einfügen und nach unten verschieben")
DeleteCell(ExcelApp,"D3",#True)
MessageRequester("Guck!", "Zelle wieder löschen und nach links verschieben")
DeleteCell(ExcelApp,"D3",#False)
MessageRequester("Guck!", "Zelle wieder löschen und nach oben verschieben")
InsertRow(ExcelApp,"C3",#True)
MessageRequester("Guck!", "Eine Zeile wurde eingefügt")
insertRow(ExcelApp,"C3",#False)
MessageRequester("Guck!", "Und diese wieder entfernt")
InsertColumn(ExcelApp,"C3",#True)
MessageRequester("Guck!", "Eine Spalte wurde eingefügt")
insertColumn(ExcelApp,"C3",#False)
EraseBorders(ExcelApp, "B2", "H5",%00111100)
MessageRequester("Guck!", "Auch der Rahmen kann entfernt werden")
MergeCells(ExcelApp, "B6", "H11", #True)
MessageRequester("Guck!", "Zellen B6 bis H11 wurden verbunden")
MergeCells(ExcelApp, "B6", "H11", #False)
MessageRequester("Guck!", "Verbundene Zellen B6 bis H11 wurden aufgehoben")
MessageRequester("Guck!", "Verschiedene Pattern werden nun angezeigt")
For i= 1 To 18
Pattern(ExcelApp,"D3:F4",i,$FF0000,#True)
Delay(1000)
Next i
MessageRequester("Guck!", "Pattern wieder ausschalten")
Pattern(ExcelApp,"D3:F4",0,0,#False)
WriteToWorksheet(ExcelApp,"MyNewSheet",1, 1, "What you her see is what you write")
For i=1 To CountSheets(ExcelApp) ; read all Sheetnames
Debug GetSheetName(ExcelApp,i)+#CRLF$
Next i
MessageRequester("Tabelle","Dieses Blatt speichern")
Datei = OpenFileRequester("Speichern unter?", StandardFile, sPattern, Pattern)
SaveWorkbookAs(ExcelApp, Datei)
SaveWorkbook(ExcelApp)
;DisplayAlertsOnOff(ExcelApp,0) ; Excel Alerts on
CloseWorkbook(ExcelApp); for changing another table, close this table.
ExcelVisible(ExcelApp,1)
MessageRequester("Exceltabelle","Nur Tabellenblatt schießen")
;...
CloseExcelAll(ExcelApp); for end of Excel
MessageRequester("Excel","Excel wurde beendet")
Else
MessageRequester("PureDispHelper-ExcelDemo", "Couldn't create Excel-Object")
EndIf
von Kiffi weitere Funktionen eingefügt , hier nochmal ein Dankeschön
Letzte Aktualisierung am 04.08.2007
[Edit]