PureBoard

Das deutsche PureBasic-Forum
https://www.purebasic.fr/german/

ExcelFunktionen PureDisphelper

https://www.purebasic.fr/german/viewtopic.php?t=13500

Seite 1 von 5

ExcelFunktionen PureDisphelper

Verfasst: 04.07.2007 18:42
von Falko
Hier habe ich einen kleinen Source, den ich mittels PureDisphelper
( 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
[Edit]Letzte Aktualisierung am 9.7.2007
von Kiffi weitere Funktionen eingefügt , hier nochmal ein Dankeschön :allright:
Letzte Aktualisierung am 04.08.2007
[Edit]

Verfasst: 04.07.2007 21:51
von mk-soft
Schöne sache :allright:

Vielleicht hat jemand lust diese mit adodb und DispHelper zu realisieren.
Dann läuft es auch, ohne das Excel installiert wurde.

FF :wink:

Verfasst: 05.07.2007 18:20
von Falko
Das wäre nicht schlecht. Im Moment sitze ich mal wieder fest und möchte
eine Funktion einbauen, die Tabellen am Anfang bzw. am Ende einfügt.

Lt. Herbers Excel-chm müsste die Funktion so geschrieben werden, die
ich versuche in PB zu implementieren. Leider funst das so nicht :freak:

Code: Alles auswählen

Procedure AddWorksheetAfter(*obj);Adds more Worksheets
   dhCallMethod(*obj,"Worksheets.Add.move after:=Worksheet(Worksheet.Count)")
EndProcedure
Das gleiche müßte auch mit before: funktionieren.

Obwohl diese funktionierende Procedure fügt am Anfang eine Tabelle ein:

Code: Alles auswählen

Procedure AddWorksheetBefore(*obj);Adds more Worksheets
   dhCallMethod(*obj,"Worksheets.Add")
EndProcedure
Könnt ihr mir sagen was ich in der ersten Procedure anpassen muß?
Im Vorraus schonmal vielen Dank :allright:

Gruß Falko

Verfasst: 06.07.2007 20:18
von schic
@Falko
Die VBA-Hilfe sagt:
Add-Methode, wie sie auf das Sheets- und Worksheets-Objekt angewendet wird.
Erstellt ein neues Arbeitsblatt, Diagramm oder Makroblatt. Das neue Arbeitsblatt wird zum aktiven Blatt.

Ausdruck.Add(Before, After, Count, Type)

Ausdruck Erforderlich. Ein Ausdruck, der eines der oben aufgeführten Objekte zurückgibt.

Before Optionaler Variant-Wert. Ein Objekt, das das Blatt festlegt, vor dem das neue Blatt eingefügt werden soll.
After Optionaler Variant-Wert. Ein Objekt, das das Blatt festlegt, nach dem das neue Blatt eingefügt werden soll.
Count Optionaler Variant-Wert. Die Anzahl der hinzuzufügenden Blätter. Der Standardwert ist Eins.
Type Optionaler Variant-Wert. Legt den Blattyp fest. Kann eine der folgenden XlSheetType-Konstanten sein: xlWorksheet, xlChart, xlExcel4MacroSheet oder xlExcel4IntlMacroSheet. Der Standardwert ist xlWorksheet.
mit dem Disphelper müsste das dann so aussehen:

Code: Alles auswählen

  Define.l ExcelApp, Workbook, Sheets, SheetN, n
  #xlWorksheet=-4167

  dhGetValue("%o", @Sheets, Workbook, ".Sheets") ;Sheets = Sheets-Auflistungsobjekt
  dhGetValue("%d", @n, Workbook, ".WorkSheets.Count") ; Count-Eigenschaft, n = Rückgabewert = Anzahle der xl-Blätter
  dhGetValue("%o", @SheetN, Workbook, ".WorkSheets(%d)",n); SheetN = Worksheets(n)
  
  dhCallMethod(Sheets, ".Add(%m ,%o,%d,%d)",SheetN,1,#xlWorksheet);
Andere und kürzere Varianten sind wohl auch möglich.

@ts-soft, @Kiffi und @mk-soft
tolle Arbeit der Disphelper. :allright:

Gruß schic

Verfasst: 07.07.2007 15:17
von Falko
@schic

Tut mir Leid, das ich mich noch nicht so mit VBA auskenne und nicht sofort
zurückgemeldet habe, aber mit deinem Beispiel funktioniert es prima.
Ich habs mal im obigen Source mit eingebunden.

Danke für deinen Tip :allright:

@Mk-Soft

>>Vielleicht hat jemand lust diese mit adodb und DispHelper zu realisieren.
>>Dann läuft es auch, ohne das Excel installiert wurde.

Darüber würde ich mich auch sehr freuen. Leider bin ich noch nicht soweit
und dieses geht eben schneller. Vorrausgesetzt man hat Excel auf
seinem Rechner.

Grüße ..Falko

Verfasst: 09.07.2007 13:21
von schic
Hallo Falko,

da gibt´s nichts zu entschuldigen. Habe die VBA-Hilfe nur als Hinweis zitiert,
da es ja auch die Variante mit After: = ... gibt und ich auch zuerst erfolglos
damit rumprobiert habe.

Naja, das mit der Parameter-Übergabe mit %m habe ich dann nur iterativ
herausgefunden ;-)

Gruß schic

Verfasst: 09.07.2007 21:28
von Falko
Hallo schic,

ich finde es schön, das man in PB nun Excel ansprechen kann.
Zwar muß man sich ein wenig mit VBA andfreunden :mrgreen: ,
aber wenn es dann funktioniert, ist man richtig happy :allright:

Der Grund für diesen Source war folgender:

Bei mir in der Firma, haben wir etliche Werkzeuglisten in Excel erstellt.
Naja, ich bin erst seit 2,5 Jahren, aufgrund eines Arbeitsunfalls, in dieser
netten Abteilung gewechselt, wobei ich allerhöchstens 15 Listen davon
erstellt habe (kopieren, ändern und speichern) .

Nun ist nach ca. 1680 Excel-Formularen meinem Kollegen aufgefallen,
das in der Fußzeile ein kleiner Fehler steckte. Von Hand alle Tabellen
ändern zu wollen wäre eine sehr zeitaufwendige Arbeit gewesen.
Da kam mir die Idee, mit einem Programm die Excelfußzeilen nach
einer Originalvorlage ändern zu wollen, was ich hier nun vorstellen möchte.

Man erstelle eine leere Exceltabelle oder auch nicht leer :lol:
und schreibe darin die passende Fußzeile. Danach starte man das folgende
Programm ExcelChangeFooter

Danach braucht man nur noch den zu ändernden Ordner auswählen
und schon kann es mit den Änderungen losgehen.
Vielleicht kann es hier und da auch jemand gebrauchen. :wink:

Grüße ..Falko

Verfasst: 09.07.2007 21:54
von mk-soft
Da haben wir ein gutes Beispiel wo für 90% der Kleinanwendungen programmiert werden.

Um den Müll der früher produziert wurde zu korrigieren.

FF :allright:

Verfasst: 12.07.2007 14:01
von mueckerich
@Falko: TNX ausgesprochen hilfreich für mich. :allright:

Hier eine klitzkleine Ergänzung zum Speichern der Exceldatei unter einem anderen Dateinamen.

Code: Alles auswählen

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

Verfasst: 12.07.2007 15:41
von Falko
@mueckerich

Das freut mich sehr.

Ich habe es oben im Beispiel ergänzt.

Vielen Dank für diese wertvolle Ergänzung :allright:


Grüße, Falko
Alle Zeiten sind UTC+02:00
Seite 1 von 5

Powered by phpBB® Forum Software © phpBB Limited

Deutsche Übersetzung durch phpBB.de