Option Explicit '********************************************************************************* ' ExcelBitmapExport.scr ' ver 1.0, 17 Jan, 2001 original release ' ver 1.1, 24 Jan, 2001 (removed reference when posting to web site) ' ' (c) 2001, Selmar Technologies, Inc. ' ' In the IpWin macro editor, make sure you have checked "Edit | References" ' Uncheck any references shown as invalid, then make sure you check: ' "Microsoft Excel 8.0 Object Library" and ' "Microsoft Office 8.0 Object Library" ' ' If you have later versions of these libraries shown, go ahead and use the ' later ones. (version 8.0 corresponds with the Office 97 product.) ' ' See text in Excel_Bitmap_Export_Help function for operating notes ' '********************************************************************************* Sub Excel_Bitmap_Export() Dim ErrorString As String Dim TempInt As Integer Dim NumFrames As Long Dim ctr As Integer IpSeqGet(SEQ_NUMFRAMES, NumFrames ) Dim exl As Excel.Application Set exl = GetExcel("") If exl Is Nothing Then ErrorString = "Unable To Open Excel; check that this Application Is installed On this machine" GoTo ExlProblem End If ' do error checking to make sure it doesn't crash next On Error GoTo ExlProblem ErrorString = "Problem adding new workbook" TempInt = exl.SheetsInNewWorkbook exl.SheetsInNewWorkbook = 1 exl.Workbooks.Add exl.SheetsInNewWorkbook = TempInt ret = IpBitShow(1) ErrorString = "Problem exporting data" With exl For ctr = 0 To (NumFrames-1) If ctr > 0 Then .ActiveWorkbook.Worksheets.Add After := .Sheets(.Sheets.Count) 'Add page To Workbook End If 'Name it "FrameN" .ActiveSheet.Name = "Fr"+Format(ctr,"000") ret = IpSeqSet(SEQ_ACTIVEFRAME, ctr) ret = IpAoiValidate() ret = IpBitSaveData("", S_CLIPBOARD) ' select upper left cell to start paste .Cells(1,1).Select 'then paste data into Excel .ActiveSheet.Paste Next ctr End With ret = IpBitShow(0) Exit Sub ExlProblem: exl.ScreenUpdating = True MsgBox(ErrorString+vbCrLf+Err.Description+vbCrLf,vbExclamation+vbApplicationModal,"Data Export Error") Err.Clear Exit Sub End Sub Sub Excel_Bitmap_Export_Help() MsgBox( " This macro will export pixel intensity data from a single image or sequence to an Excel spreadsheet. "+ _ "Before running the macro, you should place on your image an Area-of-Interest which is 256 pixels or smaller "+ _ "in width. (If your image is already 256 pixels wide or smaller, you do not need an AOI, but you may still "+ _ "wish to use one to limit the amount of data exported."+vbCrLf+vbCrLf+ _ " This macro will open Excel (if it is not already open), create a new workbook, "+ _ "and then export the intensity values from within the AOI. It places the values from "+ _ "each successive frame of your sequence into a new sheet in the workbook. The sheets will be sequentially "+ _ "named as Fr000, Fr001, Fr002, etc... Please note that this macro does not name this new workbook, nor does "+ _ "it save the workbook to disk at any time - you need to do this yourself."+vbCrLf+vbCrLf+ _ " Also note that this process may create a large amount of data, depending on the size of your "+ _ "AOI and the number of frames in your sequence."+vbCrLf+vbCrLf+ _ " ExcelBitmapExport.SCR version 1.0, Selmar Technologies, Inc. Jan, 2001.",0,"ExcelBitmapExport Script File Help") End Sub '########################################################################### ' Name: GetExcel ' Desc: Gets an Excel application object. Starts Excel if not already running. ' Loads named workbook ' ' Inputs: name of workbook to be opened. Empty string means just open Excel ' ' Returns: excel application object ("As Object") if successful ' return = "Nothing" if unsuccessful ' ' Assumes: ' ' Comments: '########################################################################### Function GetExcel(WorkbookFile As String ) As Object Dim Excel As Object ' GetObject will fail if Excel is not ' running, hence the On Error statement. On Error GoTo start_excel Set Excel = GetObject(,"Excel.Application") On Error GoTo 0 ' Debug.Print "Got past GetObject successfully" GoTo excel_running start_excel: ' Start Excel via CreateObject. If this fails, we exit the macro. ' Debug.Print "about to CreateObject" Set Excel = CreateObject("Excel.Application") ' Debug.Print "finished CreateObject" ' Excel.Workbooks.Add excel_running: Set GetExcel = Excel Excel.Visible = True ' moved this down here ' check here to see if WorkbookFile is already an open workbook. If not, open it If Len(WorkbookFile) = 0 Then Exit Function Dim a As Workbook Dim AlreadyOpen As Integer AlreadyOpen = 0 For Each a In Excel.Workbooks If a.FullName = WorkbookFile Then a.Activate AlreadyOpen = 1 End If Next a If AlreadyOpen = 0 Then Excel.Workbooks.Open FileName:=WorkbookFile End If Exit Function excel_dead: ' Debug.Print "error Creating Object" Set GetExcel = Nothing End Function