Excel helper wrapper

phishguy · Post by **phishguy** » Feb 05, 2009 18:16

I've started to write an Excel helper wrapper to simplify the use of Disphelper with Excel. I will be adding more functions as time allows.

xlhelper.bas

Link:

http://cid-53bce305c32e0874.skydrive.li ... helper.bas

Code: Select all

#define UNICODE
#include once "disphelper\disphelper.bi"

#define xlbar   2
#define xl3dbar -4100
#define byrow 1

Enum shapetypes
    pointStar16 = 94
    pointStar24 = 95
    pointStar32 = 96
    pointStar4 = 91
    pointStar5 = 92
    pointStar8 = 93
    ActionButtonBackorPrevious = 129
    ActionButtonBeginning = 131
    ActionButtonCustom = 125
    ActionButtonDocument = 134
    ActionButtonEnd = 132
    ActionButtonForwardorNext = 130
    ActionButtonHelp = 127
    ActionButtonHome = 126
    ActionButtonInformation = 128
    ActionButtonMovie = 136
    ActionButtonReturn = 133
    ActionButtonSound = 135
    Arc = 25
    Balloon = 137
    BentArrow = 41
    BentUpArrow = 44
    Bevel = 15
    BlockArc = 20
    Can = 13
    Chevron = 52
    CircularArrow = 60
    CloudCallout = 108
    Cross = 11
    Cube = 14
    CurvedDownArrow = 48
    CurvedDownRibbon = 100
    CurvedLeftArrow = 46
    CurvedRightArrow = 45
    CurvedUpArrow = 47
    CurvedUpRibbon = 99
    Diamond = 4
    Donut = 18
    DoubleBrace = 27
    DoubleBracket = 26
    DoubleWave = 104
    DownArrow = 36
    DownArrowCallout = 56
    DownRibbon = 98
    Explosion1 = 89
    Explosion2 = 90
    FlowchartAlternateProcess = 62
    FlowchartCard = 75
    FlowchartCollate = 79
    FlowchartConnector = 73
    FlowchartData = 64
    FlowchartDecision = 63
    FlowchartDelay = 84
    FlowchartDirectAccessStorage = 87
    FlowchartDisplay = 88
    FlowchartDocument = 67
    FlowchartExtract = 81
    FlowchartInternalStorage = 66
    FlowchartMagneticDisk = 86
    FlowchartManualInput = 71
    FlowchartManualOperation = 72
    FlowchartMerge = 82
    FlowchartMultidocument = 68
    FlowchartOffpageConnector = 74
    FlowchartOr = 78
    FlowchartPredefinedProcess = 65
    FlowchartPreparation = 70
    FlowchartProcess = 61
    FlowchartPunchedTape = 76
    FlowchartSequentialAccessStorage = 85
    FlowchartSort = 80
    FlowchartStoredData = 83
    FlowchartSummingJunction = 77
    FlowchartTerminator = 69
    FoldedCorner = 16
    Heart = 21
    Hexagon = 10
    HorizontalScroll = 102
    IsoscelesTriangle = 7
    LeftArrow = 34
    LeftArrowCallout = 54
    LeftBrace = 31
    LeftBracket = 29
    LeftRightArrow = 37
    LeftRightArrowCallout = 57
    LeftRightUpArrow = 40
    LeftUpArrow = 43
    LightningBolt = 22
    LineCallout1 = 109
    LineCallout1AccentBar = 113
    LineCallout1BorderandAccentBar = 121
    LineCallout1NoBorder = 117
    LineCallout2 = 110
    LineCallout2AccentBar = 114
    LineCallout2BorderandAccentBar = 122
    LineCallout2NoBorder = 118
    LineCallout3 = 111
    LineCallout3AccentBar = 115
    LineCallout3BorderandAccentBar = 123
    LineCallout3NoBorder = 119
    LineCallout4 = 112
    LineCallout4AccentBar = 116
    LineCallout4BorderandAccentBar = 124
    LineCallout4NoBorder = 120
    Mixed = -2
    Moon = 24
    NoSymbol = 19
    NotchedRightArrow = 50
    NotPrimitive = 138
    Octagon = 6
    Oval = 9
    OvalCallout = 107
    Parallelogram = 2
    Pentagon = 51
    Plaque = 28
    QuadArrow = 39
    QuadArrowCallout = 59
    Rectangle = 1
    RectangularCallout = 105
    RegularPentagon = 12
    RightArrow = 33
    RightArrowCallout = 53
    RightBrace = 32
    RightBracket = 30
    RightTriangle = 8
    RoundedRectangle = 5
    RoundedRectangularCallout = 106
    SmileyFace = 17
    StripedRightArrow = 49
    Sun = 23
    Trapezoid = 3
    UpArrow = 35
    UpArrowCallout = 55
    UpDownArrow = 38
    UpDownArrowCallout = 58
    UpRibbon = 97
    UTurnArrow = 42
    VerticalScroll = 101
    Wave = 103
End Enum

Enum linetypes 
    solid = 1
    squaredot
    rounddot
    linedash
    dashdot
    dashdotdot
    longdash
    longdashdot
    dashstylemixed = -2
End Enum

Enum xlsortorientation
    xlascending = 1
    xldescending = 2
    xlsortcolumns = 1
    xlsortrows = 2
    xltoptobottom = 1
    xllefttoright = 2
End Enum

Dim Shared xlApp As IDispatch Ptr
Dim Shared xlRange As IDispatch Ptr
Dim Shared xlRange1 As IDispatch Ptr
Dim Shared xlRange2 As IDispatch Ptr
Dim Shared xlchart As IDispatch Ptr
Dim Shared xlcells As IDispatch Ptr
Dim Shared xlsheet As IDispatch Ptr
Dim Shared xlmodule As idispatch Ptr
Dim Shared xlbook As idispatch Ptr
Dim Shared xlactivecell As idispatch Ptr
Dim Shared xlkey As idispatch Ptr
Dim Shared xlfdialog As idispatch Ptr
Dim Shared xlfilename() As String
Dim Shared xlcell1 As idispatch Ptr
Dim Shared xlcell2 As idispatch Ptr
#define  xlco  dhcreateobject
#define xlpv dhputvalue
#define xlgv dhgetvalue
#define xlcm dhcallmethod
#define csv 24
#define xlformulas -4123
#define xlpart 2
#define xlbyrows 1
#define xlnext 1
' dhInitialize(TRUE)

'opens a new spreadsheet - xlstart
Function xlstart(sheets As Integer = 3,visible As Integer = true) As Integer
    dhInitialize(TRUE)
    dhToggleExceptions(True)
    If failed(xlco("Excel.Application", NULL, @xlApp)) Then
        Return false
    Else
        xlpv(xlapp,"sheetsinnewworkbook = %d",sheets)
        xlcm( xlApp, "Workbooks.Add", "" )
        xlpv(xlApp, ".Visible = %b", visible)
        xlgv("%o",@xlSheet,xlApp,"ActiveSheet")
        Return true
    End If
End Function

Function xlhandle() As hwnd
    Dim handle As hwnd
    xlgv("%d",@handle,xlapp,".hwnd")
    Return handle
End Function

Sub xlgetworkbook()
    xlgv("%o",@xlbook,xlapp,".activeworkbook")
End Sub

Sub xladdmodule()
    xlgv("%o",@xlmodule,xlbook,".VBProject.VBComponents.Add(%d)",1)
End Sub

Sub xlsecuritylow()
    xlcm(xlapp,".AutomationSecurity = 1")
End Sub

Sub xladdmacro(macro As String)
    xlcm(xlmodule,".CodeModule.AddFromString %s",macro)
End Sub

Sub xlrunmacro(macroname As String)
    xlcm(xlapp,".Run %s",macroname)
End Sub

Sub xladdbutton( xpos As Single,ypos As Single,wdth As Single,hgt As Single)
    xlcm(xlapp,"ActiveSheet.Buttons.Add(%e,%e,%e,%e).Select",xpos,ypos,wdth,hgt)
End Sub

Sub xlonaction(macro As String)
    xlpv(xlapp,"Selection.OnAction = %s",macro)
End Sub

Sub xlprint(sheets As Integer = 1)
    xlcm(xlapp,"ActiveWindow.SelectedSheets.PrintOut %m,%m,%d,%m,%m,%m,%m,%m",sheets)
End Sub

Sub xlprintarea(area As String)
    xlpv(xlapp,"ActiveSheet.PageSetup.PrintArea = %s",area)
End Sub

'open spreadsheet with filename - xlopen ("filename.xls")
Function xlopen(filename As String,visible As Integer = true) As Integer
    dhInitialize(TRUE)
    dhToggleExceptions(True)
    If failed (xlco("Excel.Application", NULL, @xlApp)) Then
        Return false
    Else
        xlgv("%o", @xlSheet, xlApp, _
        ".Workbooks.Open(%s)",filename )
        xlpv(xlApp, ".Visible = %b", visible)
        xlgv("%o",@xlSheet,xlApp,"ActiveSheet")
        Return true
    End If
End Function

'saveas  - xlsaveas("filename.xls")
Sub xlsaveas(filename As String,filetype As Integer = -4143)
    If filetype = 6 Then
        xlcm(xlApp, ".Activeworkbook.SaveAs(%s, %d)", filename,filetype  )
        xlpv(xlApp, ".ActiveWorkbook.Saved = %b", TRUE)
    Else
        xlcm(xlApp, ".ActiveWorkbook.SaveAs(%s, %d)", filename,filetype  )
        'xlpv(xlApp, ".ActiveWorkbook.Save")
        xlpv(xlApp, ".ActiveWorkbook.Saved = %b", TRUE)
    End If
End Sub

Function xlgetfileformat() As Integer
    Dim value As Integer
    xlgv("%d",@value,xlapp,".ActiveWorkbook.FileFormat")
    Return value
End Function

Sub xlsheetsave()
    xlpv(xlsheet,".Save")
End Sub

Sub xlsave()
    xlcm(xlapp, "ActiveWorkbook.Save")
End Sub

'safe release - saferelease
Sub xlrelease()
    SAFE_RELEASE(xlCells)
    SAFE_RELEASE(xlRange)
    SAFE_RELEASE(xlRange1)
    SAFE_RELEASE(xlRange2)
    SAFE_RELEASE(xlSheet)
    SAFE_RELEASE(xlChart)
    SAFE_RELEASE(xlApp)
    SAFE_RELEASE(xlbook)
    SAFE_RELEASE(xlmodule)
    SAFE_RELEASE(xlkey)
    SAFE_RELEASE(xlcell1)
    SAFE_RELEASE(xlcell2)
    dhUninitialize(TRUE)
End Sub

'puts a string at row and column - xlputvalue(1,1,"Test")
Sub xlPutvalue (_
    Byval row As Integer,_
    Byval col As Integer,_
    Byval txt As String)
    
    xlpv(xlSheet,"cells(%u,%u)=%s",row,col,txt)   
End Sub

'selects a range of cells for subsequent formatting - xlselect("A1:D5")
Sub xlselect(range As String)
    xlgv("%o",@xlCells,xlSheet,"Range(%s)",range)
End Sub

Sub xlselectcell(row As Integer, column As Integer)
    xlgv("%o",@xlCells,xlSheet,"cells(%u,%u)",row,column)
End Sub

Sub xlcellsselect(r1 As Integer,c1 As Integer,r2 As Integer,c2 As Integer)
    xlgv("%o",@xlCell1,xlSheet,"cells(%u,%u)",r1,c1)
    xlgv("%o",@xlCell2,xlSheet,"cells(%u,%u)",r2,c2)
    xlgv("%o",@xlCells,xlSheet,"Range(%o,%o)",xlcell1,xlcell2)
End Sub

'places a border around the specified range with linestyle and border weight
Sub xlborderaround(_
    linestyle As Integer = 1,_
    borderweight As Integer = 2,_
    clr As Uinteger = 0)
    
    xlcm(xlcells, ".BorderAround(%d, %d, %m, %d)", linestyle,borderweight, clr)
End Sub

Sub xlgetrange(range As String)
    xlgv("%o", @xlRange, xlApp, ".ActiveSheet.Range(%s)", range)
End Sub

Sub xlgetrange2(r1 As Integer,c1 As Integer,r2 As Integer,c2 As Integer)
    xlgv("%o",@xlCell1,xlSheet,"cells(%u,%u)",r1,c1)
    xlgv("%o",@xlCell2,xlSheet,"cells(%u,%u)",r2,c2)
    xlgv("%o",@xlrange,xlSheet,"Range(%o,%o)",xlcell1,xlcell2)
End Sub

Function xlversion() As String
    Dim version As Zstring Ptr
    xlgv("%s",@version,xlapp,".Version")
    Return *version
End Function

'sets interior color of selected cells - xlintcolor(rgb(&h11,&h22,&h33))
Sub xlintcolor(c As Uinteger)
    xlpv(xlCells, ".Interior.Color = %d",c)
End Sub

'select the pattern of the selected range
Sub xlintpattern(p As Integer)
    xlpv(xlCells, ".Interior.Pattern = %d", p)
End Sub

'change number format of selected cells - xlnumberformat("0.00") - 2 places
Sub xlnumberformat(    f As String)
    
    xlpv(xlcells, ".NumberFormat=%s", f)
End Sub

'gets the value of cell at row and column - returnstring = xlgetvalue(2,3)
Function xlgetvalue (_
    Byval row As Integer,_
    Byval col As Integer)As String
    
    Dim As Zstring Ptr txt = NULL
    xlgv("%s",@txt,xlapp,"ActiveSheet.Cells(%d,%d)",row,col)
    Return *txt
End Function

'sets the font size of selected cells = xlfontsize(12)
Sub xlfontsize (font As Integer)
    xlpv(xlCells,".Font.Size = %d", font)
End Sub

'sets the font name of selected cells - xlfontname("Lucida Handwriting")
Sub xlfontname(fname As String)
    xlpv(xlcells,".Font.Name = %s",fname)
End Sub

'sets the border color of selected cells - xlbordercolor(rgb(0,0,0))
Sub xlbordercolor(c As Uinteger)
    xlpv(xlCells, ".Borders.Color = %d", c)
End Sub

'centers the text horizontally for selected cells - xlcenter
Sub xlhcenter()
    xlpv(xlCells, ".horizontalalignment = %d", -4108)
End Sub

'centers the text vertically for selected cells - xlvcenter
Sub xlvcenter()
    xlpv(xlCells, ".verticalalignment = %d", -4108)
End Sub

'alligns text to top of selected cells - xltop
Sub xltop()
    xlpv(xlCells, ".verticalalignment = %d", -4160)
End Sub

'alligns text to bottom of selected cells - xlbottom
Sub xlbottom()
    xlpv(xlCells, ".verticalalignment = %d", -4107)
End Sub

'alligns text to left of selected cells - xlleft
Sub xlleft()
    xlpv(xlCells, ".horizontalalignment = %d", -4131)
End Sub

'alligns text to right of selected cells - xlright
Sub xlright()
    xlpv(xlCells, ".horizontalalignment = %d", -4152)
End Sub

'sets scroll area - xlscrollarea("D1:J10")
Sub xlscrollarea(area As String)
    xlpv(xlsheet, ".ScrollArea = %s",area)
End Sub

Sub xlscrolldown(scroll As Integer)
    xlcm(xlapp,"ActiveWindow.SmallScroll  %d",scroll)
End Sub

Sub xlscrollup(scroll As Integer)
    xlcm(xlapp,"ActiveWindow.SmallScroll  %m,%d",scroll)
End Sub

Sub xlscrollright(scroll As Integer)
    xlcm(xlapp,"ActiveWindow.SmallScroll %m,%m,%d",scroll)
End Sub

Sub xlscrollleft(scroll As Integer)
    xlcm(xlapp,"ActiveWindow.SmallScroll %m,%m,%m,%d",scroll)
End Sub

Sub xlzoom(zoom As Integer)
    xlpv(xlapp,"ActiveWindow.Zoom = %d",zoom)
End Sub

Sub xladdcommandbar(barname As String,temp As Integer = true)
    xlcm(xlapp,".Application.CommandBars.Add %s,%m,%m,%b",barname, Temp)
End Sub

'move to cell - xlcellselect(2,3)
Sub xlcellselect(_
    row As Integer,_
    column As Integer)
    
    xlcm( xlSheet, "cells(%u,%u).Select",row,column )
End Sub

'hides selected row - xlhiderow
Sub xlhiderow()
    xlpv(xlapp,"ActiveCell.EntireRow.Hidden=%b",1)
End Sub

'unhides selected row - xlunhiderow
Sub xlunhiderow()
    xlpv(xlapp,"ActiveCell.EntireRow.Hidden=%b",0)
End Sub

'hides selected column - xlhidecolumn
Sub xlhidecolumn()
    xlpv(xlapp,"ActiveCell.Entirecolumn.Hidden=%b",1)
End Sub

'unhides selected column - xlunhidecolumn
Sub xlunhidecolumn()
    xlpv(xlapp,"ActiveCell.Entirecolumn.Hidden=%b",0)
End Sub

'freezes the pane at the selected cell - xlfreezepane
Sub xlfreezepane()
    xlpv(xlapp, "activewindow.FreezePanes=%b", 1 )
End Sub

'unfreezes the pane - xlunfreezepane
Sub xlunfreezepane()
    xlpv(xlapp, "activewindow.FreezePanes=%b", 0 )
End Sub

'closes the excel window - xlquit
Sub xlquit()
    xlcm(xlapp,"quit")
End Sub

'sets the text color of the selected cells - xltextcolor(rgb(0,0,0))
Sub xltextcolor(c As Ulongint)
    xlpv(xlCells, ".font.Color = %d", c)
End Sub

Sub xlborderlinestyle(s As Integer)
    xlpv(xlCells, ".Borders.LineStyle = %d", s)
End Sub

Sub xlborderweight(w As Integer)
    xlpv(xlCells, ".Borders.Weight = %d", w)
End Sub

'sets the font of selected cells to bold - xlfontbold
Sub xlfontbold(bold As boolean = true)
    xlpv(xlCells, ".font.bold=%b",bold)
End Sub   

'sets font to italic
Sub xlfontitalic(italic As boolean = true)
    xlpv(xlCells, ".font.italic=%b",italic)
End Sub       

'sets underline font
Sub xlfontunderline(underline As boolean = true)
    xlpv(xlcells,".font.underline=%b",underline)
End Sub

Sub xlsheetbackground(filename As String)
    xlcm(xlapp,"ActiveSheet.SetBackgroundPicture(%s)",filename)
End Sub


'selects sheet
Sub xlsheetselect(s As String)
    xlcm(xlApp, "worksheets(%s).Select", s )
    ' xlgv("%o",@xlSheet,xlApp,"ActiveSheet")
End Sub

'renames sheet
Sub xlsheetrename(_
    oldname As String,_
    newname As String)
    
    xlpv(xlapp,"Worksheets(%s).Name=%s",oldname,newname)
End Sub

'adds sheet
Sub xlsheetadd()
    xlcm(xlapp,"Worksheets.add")
End Sub

'deletes selected sheet
Sub xlsheetdelete()
    xlcm(xlapp,"ActiveWindow.SelectedSheets.Delete")
End Sub

'sets the color of the active sheet tab
Sub xlsheettabcolor(tabcolor As Integer = 0)
    xlpv(xlapp,"ActiveSheet.Tab.ColorIndex = %d",tabcolor)
End Sub

'marks workbook as saved to avoide prompt on quit
Sub xlsaved()
    xlpv(xlApp, ".ActiveWorkbook.Saved = %b", TRUE)
End Sub

'sets column size
Sub xlcolumnsize(w As Single)
    xlpv(xlcells,".columnwidth = %e",w)
End Sub

'set the range for sort criteria
Sub xlsetkey(r1 As Integer,c1 As Integer,r2 As Integer,c2 As Integer)
    xlgv("%o",@xlCell1,xlSheet,"cells(%u,%u)",r1,c1)
    xlgv("%o",@xlCell2,xlSheet,"cells(%u,%u)",r2,c2)
    xlgv("%o",@xlkey,xlApp,".ActiveSheet.Range(%o,%o)",xlcell1,xlcell2)
End Sub

'sorts the given range - range as nemeric rows and columns
Sub xlsort2(  r1 As Integer, c1 As Integer,r2 As Integer,c2 As Integer, _ 
    order As Integer = xlascending,orient  As Integer = xltoptobottom)
    xlgv("%o",@xlCell1,xlSheet,"cells(%u,%u)",r1,c1)
    xlgv("%o",@xlCell2,xlSheet,"cells(%u,%u)",r2,c2)
    xlgv("%o",@xlrange,xlApp,".ActiveSheet.Range(%o,%o)",xlcell1,xlcell2)
    xlcm(xlRange,".Sort(%o,%d,%m,%m,%m,%m,%m,%m,%m,%m,%d)",xlkey,order,orient)
End Sub

'sorts the given range - range as strimg
Sub xlsort(range As String,order As Integer = xlascending, _ 
    orient As Integer = xltoptobottom)
    xlgv("%o",@xlRange,xlApp,".ActiveSheet.Range(%s)",range)
    xlcm(xlRange,".Sort(%o,%d,%m,%m,%m,%m,%m,%m,%m,%m,%d)",xlkey,order,orient)
End Sub

'speak the text in the given range
Sub xlspeak(range As String)
    xlcm(xlapp,"Range(%s).Speak",range)
End Sub

'split the screen at the given column and row
Sub xlsplit(column As Integer = 1,row As Integer = 1)
    xlpv(xlapp,".ActiveWindow.SplitColumn = %d",column)
    xlpv(xlapp,".ActiveWindow.SplitRow = %d",row)
End Sub

'turn on or off grid line display
Sub xldisplaygridlines(x As Integer = true)
    xlpv(xlapp,"ActiveWindow.DisplayGridlines = %b",x)
End Sub

'turn on or off headings
Sub xldisplayheadings(x As Integer = true)
    xlpv(xlapp,"ActiveWindow.DisplayHeadings = %b",x)
End Sub

Sub xldisplayworkbooktabs(x As Integer = true)
    xlpv(xlapp,"ActiveWindow.DisplayWorkbookTabs = %b",x)
End Sub

Sub xlshowstartupdialog(x As Integer = true)
    xlpv(xlapp,".ShowStartupDialog = %b",x)
End Sub

Sub xldisplayformulabar(x As Integer = true)
    xlpv(xlapp,".DisplayFormulaBar = %b",x)
End Sub

Sub xldisplaystatusbar(x As Integer = true)
    xlpv(xlapp,".DisplayStatusBar = %b",x)
End Sub

Sub xldisplaywindowsintaskbar(x As Integer = true)
    xlpv(xlapp,".ShowWindowsInTaskbar = %b",x)
End Sub

Sub xlcommandbarview(commandbar As String,x As Integer = true)  
    xlpv(xlapp,"Application.CommandBars(%s).Visible = %b",commandbar,x)
End Sub

Sub xldrawline(x1 As Single,y1 As Single,x2 As Single,y2 As Single)
    xlcm(xlapp,"ActiveSheet.Shapes.AddLine(%e,%e,%e,%e).Select",x1,y1,x2,y2)
End Sub

Sub xlshapelineweight(weight As Integer)
    xlpv(xlapp,"Selection.ShapeRange.Line.Weight = %d",weight)
End Sub

Sub xldrawlinestyle(linestyle As Integer)
    xlpv(xlapp,"Selection.ShapeRange.Line.DashStyle = %d",linestyle)' msoLineDash
End Sub

Sub xlscaleimageheight(height As Single)
    xlcm(xlapp,"Selection.ShapeRange.ScaleHeight = %e,%b,%b",height,0,0)
End Sub

Sub xlscaleimagewidth(scalewidth As Single)
    xlcm(xlapp,"Selection.ShapeRange.ScaleWidth = %e,%b,%b",scalewidth,0,0)
End Sub

Sub xlchartwidth(chartname As String,cwidth As Single)
    xlpv(xlapp,"ActiveSheet.Shapes(%s).Width = %e",chartname,cwidth)
    xlcm(xlapp,"ActiveSheet.ChartObjects(%s).Activate",chartname)
    xlpv (xlapp,"Selection.Placement = %d",3)
End Sub

Sub xlchartheight(chartname As String,cheight As Single)
    xlpv(xlapp,"ActiveSheet.Shapes(%s).height = %e",chartname,cheight)
    xlcm(xlapp,"ActiveSheet.ChartObjects(%s).Activate",chartname)
    xlpv (xlapp,"Selection.Placement = %d",3)
End Sub

Sub xlchartxy(chartname As String, x As Single = 0,y As Single = 0)
    xlpv(xlapp,"ActiveSheet.Shapes(%s).top = %e",chartname,y)
    xlpv(xlapp,"ActiveSheet.Shapes(%s).left = %e",chartname,x)
End Sub

Sub xlchartlock(maximum As Single = 1)
    Dim minimum As Single = 0
    xlpv(xlapp,"ActiveChart.Axes(%d).MinimumScale = %e",2,minimum)
    xlpv(xlapp,"ActiveChart.Axes(%d).MaximumScale = %e",2,maximum)
End Sub

Sub xlscaleimagesize(x As Single)
    xlcm(xlapp,"Selection.ShapeRange.ScaleHeight = %e,%b,%b",x,0,0)
    xlcm(xlapp,"Selection.ShapeRange.ScaleWidth = %e,%b,%b",x,0,0)
End Sub

Sub xlimagerotate(rotation As Single)
    xlcm(xlapp,"Selection.ShapeRange.IncrementRotation = %e", rotation)' 60.36
End Sub

Sub xlshapemove(x As Single = 0,y As Single = 0)
    xlcm(xlapp,"Selection.ShapeRange.incrementleft = %e",x)
    xlcm(xlapp,"Selection.ShapeRange.incrementtop = %e",y)
End Sub

Sub xlputimagefromfile(image As String,x1 As Single,y1 As Single)
    xlcm(xlapp,"ActiveSheet.Pictures.Insert(%s).select",image)
    xlpv(xlapp,"Selection.ShapeRange.Top = %e",y1)
    xlpv(xlapp,"Selection.ShapeRange.Left = %e",x1)
End Sub

Sub xllinearrow(beginstyle As Integer _
    ,beginwidth As Integer _
    ,beginlength As Integer _
    ,endstyle As Integer _
    ,endwidth As Integer _
    ,endlength As Integer)
    
    xlpv(xlapp,"Selection.ShapeRange.Line.BeginArrowheadStyle = %d", _ 
    beginstyle)'msoArrowheadNone
    xlpv(xlapp,"Selection.ShapeRange.Line.EndArrowheadStyle = %d", _ 
    endstyle)'msoArrowheadTriangle
    xlpv(xlapp,"Selection.ShapeRange.Line.EndArrowheadWidth = %d", _ 
    endwidth)'msoArrowheadWidthMedium
    xlpv(xlapp,"Selection.ShapeRange.Line.EndArrowheadLength = %d", _ 
    endlength)'msoArrowheadLengthMedium
    xlpv(xlapp,"Selection.ShapeRange.Line.BeginArrowheadWidth = %d", _ 
    beginwidth)'msoArrowheadWidthMedium
    xlpv(xlapp,"Selection.ShapeRange.Line.BeginArrowheadLength = %d", _ 
    beginlength)'msoArrowheadLengthMedium
End Sub

'draw a shape at x,y with width w and height h - see enums for shape names
Sub xldrawshape(shape As Integer = 1,x As Single, y As Single, _ 
    w As Single, h As Single) 
    xlcm( xlapp,"ActiveSheet.Shapes.AddShape(%d,%e,%e,%e,%e).select", _
    shape,x,y,w,h)
End Sub

'set fill color of shape
Sub xlshapefillcolor(fillcolor As Uinteger)
    fillcolor = fillcolor And &hffffff
    xlpv(xlapp,"Selection.ShapeRange.Fill.ForeColor.RGB = %d",fillcolor)
    xlcm(xlapp,"Selection.ShapeRange.Fill.Solid")
End Sub

'set line color of shape
Sub xlshapelinecolor(linecolor As Uinteger)
    linecolor = linecolor And &hffffff
    xlpv(xlapp,"Selection.ShapeRange.Line.ForeColor.RGB = %d",linecolor)
End Sub

'put text in shape
Sub xlshapetext(text As String)
    xlpv(xlapp,"Selection.Characters.Text = %s",text)
End Sub

Sub xlshapetextcolor(colour As Uinteger = Rgb(0,0,0))
    xlpv(xlapp,"Selection.Characters.font.color = %d",Colour)
End Sub

Sub xlshapetextfont(fontname As String = "Arial")
    xlpv(xlapp,"Selection.Characters.Font.Name = %s",fontname)
End Sub

Sub xlshapetextfontsize(size As Integer = 10)
    xlpv(xlapp,"Selection.Characters.Font.Size = %d",size)
End Sub

'sets row size
Sub xlrowsize(h As Single)
    xlpv(xlcells,".rowheight = %e",h)
End Sub

'merges cell range
Sub xlmergerange(range As String)
    xlcm(xlSheet, ".Range(%s).Merge", range)
End Sub

'merges cells
Sub xlmerge()
    xlcm(xlcells, ".Merge")
End Sub

'merges cells and centers text 
Sub xlmerge_center()
    xlcm(xlcells,".Merge")
    xlpv(xlCells, ".horizontalalignment = %d", -4108)
End Sub

'test for fail (used to trap if spreadsheet is in edit mode)
Function xlfailed() As Integer
    Dim As Zstring Ptr txt = NULL
    If failed(xlgv("%s",@txt,xlapp,"ActiveSheet.Cells(%d,%d)",1,1)) Then
        Return true
    Else
        Return false
    End If
End Function

'add a chart
Sub xlchartadd()
    xlgv("%o", @xlChart, xlApp, ".ActiveWorkbook.Charts.Add")
End Sub

Sub xlchartaddV2()
    xlcm(xlapp,"ActiveSheet.Shapes.AddChart.Select")
    xlcm(xlapp,".ActiveChart.SetSourceData Source:=(%o)",xlrange)
End Sub

Sub xlcharttitle(title As String)
    xlcm (xlapp,"ActiveChart.SetElement = %d", 2)
    xlpv(xlapp,"Selection.Caption = %s",title)
End Sub

Sub xlcharttype(ctype As Integer = 54,varybycat As Integer = true, _ 
    group As Integer = 1)
    xlpv(xlapp,".Activechart.ChartType = %d",ctype )
    xlpv(xlapp,"Activechart.ChartGroups(%d).VaryByCategories = %b", _ 
    group,varybycat)
End Sub

'place the chart
Sub xlputchart(sname As String)
    xlcm(xlChart, ".Location(%d,%s)", 2, sname)
End Sub

'chart wizard for generating charts
Sub xlchartwizard(_
    charttype As Integer = xl3dbar,_
    variant As Integer = 1,_
    plotby As Integer = byrow,_
    catlabels As Integer = 1,_
    serieslabels As Integer = 0,_
    haslegend As Integer = false,_
    title As String = "")
    
    xlcm(xlChart, ".ChartWizard(%o, %d, %d, %d, %d, %d, %b, %s)", _
    xlRange, charttype,variant, plotby,catlabels _
    , serieslabels, haslegend, title)
End Sub

Sub xlcharthasaxis(_
    n As Integer = 3,_
    state As Integer = false)
    
    xlpv(xlChart, ".HasAxis(%d) = %b", n,state)
End Sub

Sub xlchartdelete(chartname As String)
    xlcm(xlapp,".ActiveSheet.ChartObjects(%s).Activate",chartname)
    xlcm(xlapp,"ActiveChart.Parent.Delete")
End Sub

'auto formats the selected range
Sub xlautoformat(_
    fmat As Integer = -4154,_
    number As Integer = true,_
    font As Integer = true,_
    alignment As Integer = true,_
    border As Integer = true,_
    pattern As Integer = true,_
    wid As Integer = true)
    
    xlcm(xlcells,_
    ".AutoFormat(Format=%d,Number=%b,Font=%b,Alignment=%b,Border=%b,Pattern=%b,Width=%b"_
    ,fmat,number,font,alignment,border,pattern,wid)
End Sub

'copy selected range to clipboard
Sub xlcopy()
    xlcm(xlcells,".Copy")
End Sub

'paste clipboard to selected range
Sub xlpaste()
    xlcm(xlsheet,".Paste")
End Sub

Sub xlrangeselect2(r1 As Integer,c1 As Integer,r2 As Integer,c2 As Integer)
    xlgv("%o",@xlCell1,xlSheet,"cells(%u,%u)",r1,c1)
    xlgv("%o",@xlCell2,xlSheet,"cells(%u,%u)",r2,c2)
    xlcm(xlSheet,"Range(%o,%o).Select",xlcell1,xlcell2)
End Sub

Sub xlgetranges(r1 As Integer,c1 As Integer,r2 As Integer,c2 As Integer, _ 
    r3 As Integer, c3 As Integer, r4 As Integer, c4 As Integer)
    xlgv("%o",@xlCell1,xlSheet,"cells(%u,%u)",r1,c1)
    xlgv("%o",@xlCell2,xlSheet,"cells(%u,%u)",r2,c2)
    xlgv("%o",@xlrange1,xlSheet,"Range(%o,%o) ",xlcell1,xlcell2)
    xlgv("%o",@xlCell1,xlSheet,"cells(%u,%u)",r3,c3)
    xlgv("%o",@xlCell2,xlSheet,"cells(%u,%u)",r4,c4)
    xlgv("%o",@xlrange2,xlSheet,"Range(%o,%o) ",xlcell1,xlcell2)
    xlgv("%o",@xlrange,xlapp,"Union(%o,%o)",xlrange1,xlrange2)
End Sub

'select a range of cells
Sub xlRangeselect(range As String)
    xlcm( xlSheet, ".Range(%s).Select",range )
End Sub

'cut the selected range to clipboard
Sub xlcut()
    xlcm(xlcells,".Cut")
End Sub

'get the name of the desired sheet number
Function xlgetsheetname(sheetnumber As Integer = 1 ) As String
    Dim sheetname As Zstring Ptr
    xlgv("%s",@sheetname,xlapp,".Worksheets.item(%d).name",sheetnumber)
    Return *sheetname
End Function

Function xlpastearray(_
    array() As String,_
    startZ As String = "A1",_
    flipZ As Integer = 0) As Integer
    '
    Dim As Integer c,d,i,j,r,indices(1)
    Dim As Integer colZ,rowZ,lcol,lrow
    Dim As String  cZ,kz,rZ,rangeZ,tstr
    Dim ws As Wstring * 256
    Dim As HRESULT hres
    Dim As VARIANT arr,tmp
    Dim As BSTR    bptr
    Dim As SAFEARRAYBOUND sab(1)
    
    '
    If Len(startZ)<2 Then Return            -1
    '
    tstr=Ucase(startZ)
    If tstr[0]<65 Or tstr[0]>90 Then Return -1
    '
    Asm
        mov esi, [ebp+8]
        mov eax, [esi+16]
        mov [d], eax
    End Asm
    If d<1 Or d>2 Then Return               -2
    '
    If d>1 Then
        lcol=Lbound(array,2)
        colZ=Ubound(array,2)-lcol+1
        lrow=Lbound(array,1)
        rowZ=Ubound(array,1)-lrow+1
    Else
        lcol=Lbound(array,1)
        colZ=Ubound(array,1)-lcol+1
        lrow=lcol
        rowZ=1
        If flipZ Then Swap colZ,rowZ
    End If
    If rowZ<1 Or colZ<1 Then Return         -2
    '
    kZ=""
    If tstr[1]<65 Then
        c=tstr[0]-64
        kZ=Left(tstr,1)
        r=Val(Right((tstr),Len(tstr)-1))
    Elseif tstr[2]<65 Then
        c=((tstr[0]-64)*26)+(tstr[1]-64)
        kZ=Left(tstr,2)
        r=Val(Right((tstr),Len(tstr)-2))
    Elseif tstr[2]>64 Then
        c=((tstr[0]-64)*676)+((tstr[1]-64)*26)+(tstr[2]-64)
        kZ=Left(tstr,3)
        r=Val(Right((tstr),Len(tstr)-3))
    End If
    If c<1 Or r<1 Then Return               -1
    '
    cZ=""
    i=colZ+c-1
    d=i
    If i>702 Then
        j=d\676
        cZ = Chr(j+64)
        d -= j*676
        j=d\26
        cZ &= Chr(j+64)
        d -= j*26
        cZ &= Chr(d+64)
    Elseif i=702 Then
        cZ="ZZ"
    Elseif i>26 Then
        j=d\26
        cZ &= Chr(j+64)
        d -= j*26
        cZ &= Chr(d+64)
    Else
        cZ &= Chr(i+64)
    End If
    '
    cZ &= Str(rowZ+r-1)
    rZ  = kZ & Str(r)
    rangeZ= rZ & ":" & cZ
    '
    arr.vt = VT_ARRAY Or VT_VARIANT
    sab(0).lLbound = lrow : sab(0).cElements = rowZ
    sab(1).lLbound = lcol : sab(1).cElements = colZ
    '
    arr.parray=SafeArrayCreate(VT_VARIANT,2,Cast(SAFEARRAYBOUND Ptr,@sab(0)))
    '
    For i = lrow To rowZ
        For j = lcol To colZ
            '
            If rowZ=1 Then
                ws=Wstr(array(j))
            Elseif colZ=1 Then
                ws=Wstr(array(i))
            Else
                ws=Wstr(array(i,j))
            End If
            bptr=SysAllocString(@ws)
            tmp.vt      = VT_BSTR
            tmp.bstrVal = bptr
            '
            indices(0)=i
            indices(1)=j
            '
            hres=SafeArrayPutElement(arr.parray,@indices(0),@tmp)
            '
            SysFreeString(bptr)
            '
        Next
    Next
    '
    hres=dhPutValue(xlApp,".ActiveSheet.Range(%s) = %v",rangeZ,@arr)
    
    VariantClear(@tmp)
    SafeArraydestroy(arr.parray)
    
    '
    Return Iif(hres<>0,-3,0)
    '
End Function

Sub xlactiveintcolor(clr As Uinteger)
    xlpv(xlapp, ".activecell.Interior.Color = %d",clr)
End Sub


Sub xlfind(text As String)
    dhtoggleexceptions(false)
    Dim count As Integer
    
    xlgv("%o",@xlactivecell,xlapp,".activecell") 'get activecell
    xlgv("%d",@count,xlapp,"worksheets.count")
    
    For x As Integer = 1 To count
        xlcm(xlapp,"worksheets.item(%d).select",x)
        
        If Not failed(xlcm(xlapp,".cells.find(%s,%o,%d,%d,%d,%d,%b,%b).select" _
        ,text,xlactivecell,xlFormulas,xlPart,xlByRows,xlNext,False,False)) Then  
        Exit For
    End If
    
Next x

dhtoggleexceptions(true)
End Sub

Function xlgetrow() As Integer
    Dim rowval As Integer
    xlgv("%d",@rowval,xlapp,".selection.row")
    Return rowval
End Function

Function xlgetcolumn() As Integer
    Dim columnval As Integer
    xlgv("%d",@columnval,xlapp,".selection.column")
    Return columnval
End Function

Sub xlrowintcolor(clr As Uinteger)
    xlpv(xlapp,".rows(%d).interior.color = %d",xlgetrow,clr)
End Sub

Function xlgetintcellcolor(r As Integer,c As Integer) As Integer
    Dim cval As Integer
    xlgv("%d",@cval,xlapp,".cells(%d,%d).interior.color",r,c)
    Return cval
End Function

Function xlfiledialog(filtername As String = "Basic Files", _ 
    filtertype As String = "*.bas", _ 
    filterorder As Integer = 1, _
    initialdir As String = "C:\Freebasic\", _ 
    title As String = "Freebasic", _ 
    multiselect As Integer = true ) As Long
    xlgv("%o",@xlfdialog,xlapp,".filedialog(%d)",3)
    Dim selected As Long
    Dim count As Long
    Dim filen As zstring Ptr
    ' Set up file filters
    xlcm(xlfdialog,".Filters.Add %s, %s, %d",filtername, filtertype,filterorder)
    
    ' Set initial directory
    xlpv(xlfdialog,".initialfilename = %s",initialdir)
    
    ' Allow selection of multiple files
    xlpv(xlfdialog,".allowmultiselect = %b",multiselect)
    
    'Add a title to the dialog window
    xlpv(xlfdialog,".title = %s",title)
    
    'show the dialog and check if files selected
    xlgv("%d",@selected,xlfdialog,".show") 
    
    If selected = -1 Then
        
        'Get the count of selected items
        xlgv("%d",@count,xlfdialog,".selecteditems.count")
        Redim xlfilename(count)  
        ' Get paths and file names of each file selected 
        For x As Integer = 1 To Count 
            xlgv("%s",@filen,xlfdialog,".selecteditems(%d)",x)
            xlfilename(x) = *filen 
        Next x 
    End If
    Return count
End Function

'Creates a table with the previously specified range (xlrangeselect2).
'The first time called on a sheet the table name will be Table1.
'The next time a table is created it will be Table2.
sub xltableadd()
xlcm(xlapp,"activesheet.listobjects.add")
end sub

'Sets the display style for the table
sub xltablestyle(tablename as string = "Table1", _
    tablestyle as string = "TableStyleMedium22")
    xlpv(xlapp, _ 
"ActiveSheet.ListObjects(%s).TableStyle = %s",tablename,tablestyle)
end sub

'Sets whether totals are display
sub xltableshowtotals(tablename as string = "Table1", _ 
    showtotals as integer = true)
xlpv(xlapp,"ActiveSheet.ListObjects(%s).ShowTotals = %b",tablename,showtotals)
end sub

'Adds a calculation method for the selected column
sub xltableaddcalc(tablename as string = "Table1", _
    calcheader as string = "Column1", _
    calculationmethod as integer = 3)
xlpv(xlapp, _ 
"ActiveSheet.ListObjects(%s).ListColumns(%s).TotalsCalculation = %d", _ 
tablename,calcheader,Calculationmethod)
end sub

'renames the table
sub xltablerename(oldname as string = "Table1", newname as string)
xlpv(xlapp,"ActiveSheet.ListObjects(%s).Name = %s",oldname,newname)
End Sub
    

Sub xlvisible(state As Integer = true)
    xlpv(xlApp, ".Visible = %b", state)
End Sub

BasicScience · Post by **BasicScience** » Feb 05, 2009 18:36

Thanks... this will be very useful.

Would be nice to add a function to Close Excel too.

phishguy · Post by **phishguy** » Feb 05, 2009 18:47

Added the quit (xlquit) - see first post.
Also added xltextcolor

I will try and add the chart wizard next. It's a little more complex though.

Loe · Post by **Loe** » Feb 06, 2009 1:05

Hi phishguy,
quick look to your excel helper, I found it work for single document of excel. I mean currently, it for single workbook and single worksheet (Active document).
if you dont mind, its nice if you make it for multiple document.
as you know, in vba we can use sheets(sheetname).cells(1,1).value=1.

phishguy · Post by **phishguy** » Feb 06, 2009 1:22

Ok, that will be added to the list of many things I want to add. I will probably make it as a command to change the active sheet.

phishguy · Post by **phishguy** » Feb 06, 2009 14:28

Added:
xltextcolor
xlfontbold
xlfontitalic
xlfontunderline
xlsheetselect
xlborderlinestyle
xlborderweight

See first post.

BasicScience · Post by **BasicScience** » Feb 06, 2009 15:47

More gems.... thanks.

The wrapper functions work properly, but I've noticed a strange change in Excel. Ever since launching Excel from disphelper, the title bar has changed such that the min/max/close buttons now operate on the active window within excel, not on the application itself. This change remains even when Excel is launched from outside FB. It's probably an excel toolbar issue, not really a FB issue... but it seems to have been altered by launching excel with disphelper.

phishguy · Post by **phishguy** » Feb 06, 2009 16:09

I'm not sure, but I think that is caused by this line.

Code: Select all

dhPutValue(xlApp, ".DisplayFullScreen = %b", true)

I will test this later to confirm.

<edit>
Yep, that was it. Fixed in first post.
Added:
xlsheetrename
xlsheetadd
xlsheetdelete
xlfontname
xlleft
xlright
xltop
xlbottom
xlvcenter
xlrowsize
xlcolumnsize
xlsaved

Changed:
xlfont to xlfontsize
xlcenter to xlhcenter

Modified example to show additional features. See first post.

nobozoz · Post by **nobozoz** » Feb 08, 2009 3:15

Seems to be very easy to use.

Can this code be used backwards, say to access an FB COM server from Excel?

Thanks.

phishguy · Post by **phishguy** » Feb 08, 2009 4:04

@nobozoz
Sorry, I don't know. Com servers are beyond my understanding.

phishguy · Post by **phishguy** » Feb 09, 2009 22:00

Added
xlmerge
xlfailed
xlchartadd
xlputchart
xlchartwizard
xlgetrange
xlcharthasaxis
xlborderaround

Here is an example with a chart:

http://cid-53bce305c32e0874.skydrive.li ... 20demo.bas

Here is the same code without the wrapper:

http://cid-53bce305c32e0874.skydrive.li ... rapper.bas

phishguy · Post by **phishguy** » Feb 10, 2009 14:14

Changed:
xlrowsize and xlcolumn size now pass a Single instead of an Integer.

xlstart now has optional parameter of number of sheets to open. Default equals 3.

example:
xlstart(1)
Opens an Excel workbook with 1 sheet.

First demo updated.

phishguy · Post by **phishguy** » May 27, 2009 17:40

Added xlautoformat.

See first post.

phishguy · Post by **phishguy** » May 28, 2009 19:36

Changed xlnumberformat to use current selection instead of a row.

Also change xlborderaround to use current selection and added the border line style and border weight.

Added:
xlcopy
xlpaste
xlrangeselect
xlcut

Added a few more comments in the code.

See first post.

phishguy · Post by **phishguy** » Jun 04, 2009 23:44

Changed xlfontbold, xlfontitalic, and xlfontunderline to accept true or false arguments.

Also fixed bug in xlsaveas.

Here is a short example:

http://cid-53bce305c32e0874.skydrive.li ... atting.bas