Option Explicit Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub Main ' This cross section routine is created by CalcImage Dim Directory As String Directory$ = "C:\UserData\SurferData\" ' this line points to the data folder containing all files Directory$ = CurDir$() & "\" ' comment out this line if running on Win7 64 bit Dim Sample As String Sample$ = "azl-c-02 d PIS 22" Dim iMax As Integer iMax% = 3 ReDim FileArray(1 To iMax%) As String FileArray$(1) = "XYSCAN2_Fe Elemental Percents" FileArray$(2) = "XYSCAN2_K Elemental Percents" FileArray$(3) = "XYSCAN2_Si Elemental Percents" ReDim ZLabel(1 To iMax%) As String ZLabel$(1) = "Fe Wt. Percents" ZLabel$(2) = "K Wt. Percents" ZLabel$(3) = "Si Wt. Percents" ' Change back to data folder (need for Win 7 64 bit) ChDrive Directory$ ChDir Directory$ Dim DigitizeGRDNum As Integer DigitizeGRDNum% = 1 ' default is first file (edit as necessary) ' Call output routine Call OutputBoundaryLine(Directory$, FileArray$(), iMax%, DigitizeGRDNum%) Call OutputMapPage(Directory$, FileArray$(), iMax%, ZLabel$()) End Sub Sub OutputBoundaryLine(Directory$, FileArray() As String, iMax As Integer, GRDNum As Integer) ' Making the Image Map with Boundary Line overlaid Dim astring As String Dim DigitizeFile As String If GRDNum% < 1 Or GRDNum% > iMax% Then MsgBox("GRD file number " & Format$(GRDNum%) & " is not valid (must be between 1 and " & Format$(iMax%) & "). Please edit variable DigitizeGRDNum above and try again.", vbOkOnly + vbExclamation, "OutputBoundaryLine") End End If DigitizeFile$ = FileArray$(GRDNum%) ' Declares SurferApp as an object Dim SurferApp As Object ' Creates an instance of the Surfer Application object and assigns it to the variable named "SurferApp" Set SurferApp = CreateObject("Surfer.Application") ' Make my actions visible on the screen SurferApp.Visible = True ' Check version number If Val(Left$(SurferApp.Version, 2)) <= Val("7.") Then astring$ = "This polygon extraction script requires v. 8 or higher of Surfer Scripter (from Golden Software). Please upgrade your Surfer version." MsgBox astring$, vbOkOnly + vbCritical, "OutputBoundaryLine" End If ' Declares Plot as an object Dim Plot As Object ' Creates a plot document in Surfer and assigns it to the variable named "Plot" Set Plot = SurferApp.Documents.Add(srfDocPlot) ' Declares Shapes as an object Dim Shapes As Object ' Assigns the Shapes collection to the variable named "Shapes" Set Shapes = Plot.Shapes ' Declares MapFrame as an object Dim MapFrame As Object ' Create the file name for the grid file using to make the Image Map Dim FileGridMap As String FileGridMap$ = Trim$(Directory$) & Trim$(DigitizeFile$) & ".grd" If Dir$(FileGridMap$) = "" Then MsgBox("File " & FileGridMap$ & " was not found. If this is Win 7 64 bit, comment out the second Directory$ = statement above and try again.", vbOkOnly + vbExclamation, "OutputBoundaryLine") End End If ' Creates an Image Map and assigns the map coordinate system to the variable named "MapFrame" Set MapFrame = Shapes.AddImageMap(GridFileName:=FileGridMap$) ' Declares ImageMap as an object Dim ImageMap As Object ' Assigns the image map properties to the variable named "ImageMap" Set ImageMap = MapFrame.Overlays(1) ' Dialog box to pop up for you to create the Boundary line Begin Dialog UserDialog 490,273 ' %GRID:10,7,1,1 Text 10,7,430,14,"Manually digitize the Image Map:",.Text1 Text 30,28,430,14,"1.Select the Image Map",.Text2 Text 30,49,430,14,"2.Select Digitize from the Map menu",.Text3 Text 30,70,430,28,"3.Left click on the image where you want the end points of your Boundary line to be (the line the image will be cross sectioned along)",.Text4 Text 30,105,430,28,"4.In the pop-up box that appears with your data points, go the File menu and then Save As",.Text5 Text 30,140,430,77,"5.Name the Blanking file (.bln) just created as ""BoundaryLine"" and save in your data folder (" & CurDir$ & ").",.Text6 PushButton 10,224,470,42,"Finished Digitizing",.PushButton1 End Dialog Dim dlg As UserDialog Dialog dlg ' Close the Surfer Application SurferApp.Documents.CloseAll(SaveChanges:=srfSaveChangesNo) SurferApp.Quit End Sub Sub OutputMapPage(Directory$, FileArray$(),iMax%, ZLabel$()) 'Creating loop to go through all the files Dim i As Integer For i% = 1 To iMax% '''''' Opening Surfer and setting up again 'Declares SurferApp as an object Dim SurferApp As Object 'Creates an instance of the Surfer Application object and assigns it to the variable named "SurferApp" Set SurferApp = CreateObject("Surfer.Application") 'Make my actions visible on the screen SurferApp.Visible = True 'Declares Plot as an object Dim Plot As Object 'Creates a plot document in Surfer and assigns it to the variable named "Plot" Set Plot = SurferApp.Documents.Add(srfDocPlot) 'Declares PageSetup as an object Dim PageSetup As Object 'Assigns the plot document page setup to the variable named "PageSetup" Set PageSetup = Plot.PageSetup 'Change orientation of page to landscape PageSetup.Orientation = srfLandscape 'Declares Shapes as an object Dim Shapes As Object 'Assigns the Shapes collection to the variable named "Shapes" Set Shapes = Plot.Shapes 'Titling the page with sample and file name Dim Text As Object Set Text = Shapes.AddText(x:=0.75, y:=7.75, Text:=FileArray$(i)) Text.Font.Size = 18 Text.Font.Bold = True '''''' Making the Image Map with Boundary Line overlaid 'Create the Image Map 'Declares MapFrame as an object Dim MapFrame As Object 'Create the file name for the grid file using to make the Image Map Dim FileGridMap As String FileGridMap$ = Trim$(Directory$) & Trim$(FileArray$(i)) & ".grd" 'Creates an Image Map and assigns the map coordinate system to the variable named "MapFrame" Set MapFrame = Shapes.AddImageMap(GridFileName:=FileGridMap$) 'Declares ImageMap as an object Dim ImageMap As Object 'Assigns the image map properties to the variable named "ImageMap" Set ImageMap = MapFrame.Overlays(1) 'Make the image map in color Dim ColorImageMap As Object 'Set color palette Set ImageMap = MapFrame.Overlays(1) ImageMap.ShowColorScale = True 'Assigns the color spectrum properties to the variable named Set ColorImageMap = ImageMap.ColorMap 'Set color scale significant digits ImageMap.ColorScale.LabelFormat.NumDigits = 1 ImageMap.ColorScale.LabelFormat.Type = 1 ' 1 = Fixed, 2 = Exponential, 3 = Compact 'Format text in color scale ImageMap.ColorScale.LabelFont.Size = 14 'Load color spectrum depending on version number If Val(Left$(SurferApp.Version, 2)) <= Val("8.") Then ColorImageMap.LoadFile(SurferApp.Path & "\Samples\Rainbow2.clr") Else ColorImageMap.LoadFile(SurferApp.Path & "\ColorScales\Rainbow2.clr") End If 'Resize the color scale ImageMap.ColorScale.Selected = True ImageMap.ColorScale.Width = 0.5 ImageMap.ColorScale.Height = 3 'Move the color scale ImageMap.ColorScale.Left = 10 ImageMap.ColorScale.Top = 7.875 'Create Base Map for Boundary line created manually Dim BoundaryLine As Object 'Create the file name for the Boundary file created Dim FileBoundaryLine As String FileBoundaryLine$ = Trim$(Directory) & "BoundaryLine" & ".bln" If Dir$(FileBoundaryLine$) = "" Then Dim astring As String astring$ = "Boundary file " & FileBoundaryLine$ & " was not found." MsgBox astring$, vbOkOnly + vbCritical, "OutputMapPage" End End If Set BoundaryLine = Shapes.AddBaseMap(ImportFileName:=FileBoundaryLine$) Dim BaseMap As Object Set BaseMap = BoundaryLine.Overlays(1) BaseMap.Line.ForeColor = srfColorWhite 'Coloring the line BaseMap.Line.Width = 0.02 'Making the line wider 'Create Post Map to label using the alphabet (A,B,C...) 'Making file with labels for Boundary Line (currently set up for up to 26 points) Dim LabelWks As Object Set LabelWks = SurferApp.Documents.Open(FileName:=FileBoundaryLine$) 'Remove first row of non-used values (will plot if not removed) Dim LabelWksRange As Object Sleep(200) Set LabelWksRange = LabelWks.Rows(Row1:=1, Row2:=1) LabelWksRange.Delete(Direction:=wksDeleteUp) 'Put labels in column 3 for BoundaryLine points 'Count the number of rows for use in distance calculation Dim PointsRange As Object Set PointsRange = LabelWks.Columns(Col1:=1, Col2:=2) Dim TotalPoints As Integer TotalPoints% = PointsRange.RowCount 'Put letter labels in for points Dim MaxPoints As Integer MaxPoints% = 26 'To use all letters of the alphabet to label the BoundaryLine Dim LabelRow As Integer Dim Letter As Integer Letter = 65 'To use ascii characters ("A" is #65) For LabelRow% = 1 To MaxPoints% 'Loop through the alphabet and put letters into label column LabelWks.Cells(LabelRow,3) = Chr(Letter%) Letter = Letter + 1 Next LabelRow% 'Make columns with the distances along the BoundaryLine (to use on Cross Section graph later) 'Calculate the distances along the BoundaryLine 'Calculate the distance between points Dim FirstXRow As Integer FirstXRow = 1 Dim FirstYRow As Integer FirstYRow = 1 Dim SecondXRow As Integer SecondXRow = 2 Dim SecondYRow As Integer SecondYRow = 2 Dim FirstX As Object Dim FirstY As Object Dim SecondX As Object Dim SecondY As Object Dim DistanceRows As Integer Dim Distance As Object For DistanceRows% = 2 To TotalPoints% Set FirstX = LabelWks.Cells(Row:=FirstXRow%, col:=1) Set FirstY = LabelWks.Cells(Row:=FirstYRow%, col:=2) Set SecondX = LabelWks.Cells(Row:=SecondXRow%, col:=1) Set SecondY = LabelWks.Cells(Row:=SecondYRow%, col:=2) Set Distance = LabelWks.Cells(Row:=DistanceRows%, col:=4) Distance.Value = ( ((SecondX-FirstX)^2)+ ((SecondY-FirstY)^2)) ^ (1/2) FirstXRow = FirstXRow + 1 FirstYRow = FirstYRow + 1 SecondXRow = SecondXRow + 1 SecondYRow = SecondYRow + 1 Next DistanceRows% 'Put zero in for first row (since it's the starting point) Dim StartValue As Object Set StartValue = LabelWks.Cells(Row:=1, col:=4) StartValue.Value = 0 'Calculate the TOTAL distance traveled along the BoundaryLine 'Put zero in for first row (since it's the starting point) Set StartValue = LabelWks.Cells(Row:=1, col:=5) StartValue.Value = 0 Dim TotalDistance As Object Dim DistanceTraveled As Object Dim DistanceToNextPoint As Object Dim DistanceTraveledRow As Integer For DistanceRows% = 2 To TotalPoints% DistanceTraveledRow = DistanceRows% - 1 Set DistanceTraveled = LabelWks.Cells(Row:=DistanceTraveledRow%, col:=5) Set DistanceToNextPoint = LabelWks.Cells(Row:=DistanceRows%, col:=4) Set TotalDistance = LabelWks.Cells(Row:=DistanceRows%, col:=5) TotalDistance.Value = DistanceTraveled + DistanceToNextPoint Next DistanceRows% Dim CrossXMax As Double CrossXMax# = TotalDistance + (0.01 * TotalDistance) Dim CrossXMin As Double CrossXMin# = 0 - (0.01 * TotalDistance) 'Remove unneeded rows Dim UnusedRows As Integer UnusedRows% = TotalPoints% + 1 Dim CutRow As Object Set CutRow = LabelWks.Rows(Row1:=UnusedRows%, Row2:=29) CutRow.Cut 'Create the file name for the Boundary Line label file Dim FileBoundaryLabels As String FileBoundaryLabels$ = Trim$(Directory) & "BoundaryLineLabels" & ".dat" 'Save Boundary Line label data file LabelWks.SaveAs(FileName:=FileBoundaryLabels$) 'Keep worksheet open to modify later 'Make Post Map Dim LabelMap As Object Set LabelMap = Shapes.AddPostMap(DataFileName:=FileBoundaryLabels$) Dim LabelPostMap As Object Set LabelPostMap = LabelMap.Overlays(1) LabelPostMap.Symbol.Size = "0.02" 'Label Post Map LabelPostMap.LabCol = 3 LabelPostMap.LabelPos = srfPostPosLeft LabelPostMap.LabelFont.Size = 16 LabelPostMap.LabelFont.Bold = True LabelPostMap.LabelFont.Color = srfColorWhite LabelPostMap.Symbol.Set="GSI Default Symbols" LabelPostMap.Symbol.Index = 12 LabelPostMap.Symbol.Size = 0.05 LabelPostMap.Symbol.Color = srfColorWhite 'Overlay Image Map with Boundary line and labels 'Select Image and Base Maps created MapFrame.Selected = True BoundaryLine.Selected = True LabelMap.Selected = True 'Declares selected maps as object Dim SelectMaps As Object 'Assigns the Selection collection to a variable named "SelectMaps" Set SelectMaps = Plot.Selection 'Overlays the Image and Base Maps SelectMaps.OverlayMaps 'Formatting combined map 'Makes maps 3" x 3" square MapFrame.xLength = 3 MapFrame.yLength = 3 'Positioning map in upper right corner of page MapFrame.Left = 6 MapFrame.Top = 8 'Deselect overlaid maps MapFrame.Deselect '''''' Creating the Cross Section 'Slicing the grid along the Boundary line created 'Create the file name for the Data Output file to be created Dim FileDataOutput As String FileDataOutput$ = Trim$(Directory$) & "BoundaryLine" & ".dat" 'Slice the Grid file along your BoundaryLine SurferApp.GridSlice(InGrid:=FileGridMap$,BlankFile:=FileBoundaryLine$,OutDataFile:=FileDataOutput$, OutsideVal:=-8888, BlankVal:=-9999) 'Save copy of the Data output from the Grid Slice (.dat and .xls) Dim OutputWks As Object Set OutputWks = SurferApp.Documents.Open(FileName:=FileDataOutput$) 'Label the columns in the file Dim Acol, Bcol, Ccol, Dcol, Ecol As Object Set Acol = OutputWks.Cells("A1") Acol.Value = "X Coordinate" Set Bcol = OutputWks.Cells("B1") Bcol.Value = "Y Coordinate" Set Ccol = OutputWks.Cells("C1") Ccol.Value = "Z Value (Element %)" Set Dcol = OutputWks.Cells("D1") Dcol.Value = "Distance Along Boundary Line" Set Ecol = OutputWks.Cells("E1") Ecol.Value = "Boundary Number" 'Save .dat file Dim FileCrossSectionDAT As String FileCrossSectionDAT$ = Trim$(Directory) & Trim$(FileArray$(i)) & "_" & "CrossSection" & ".dat" OutputWks.SaveAs(FileName:=FileCrossSectionDAT$) 'Save .xls file Dim FileCrossSectionXLS As String FileCrossSectionXLS$ = Trim$(Directory) & Trim$(FileArray$(i)) & "_" & "CrossSection" & ".xls" OutputWks.SaveAs(FileName:=FileCrossSectionXLS$) SurferApp.ActiveDocument.Close 'Modifying Slice Data File to make Blanking File for Base Map of Cross Section 'Declares Wks as an object Dim Wks As Object 'Opens a worksheet document in Surfer and assigns it to the variable named "Wks" Set Wks = SurferApp.Documents.Open(FileName:=FileDataOutput$) 'Declares WksRange as an object Dim WksRange As Object 'Assigns Columns A and B to the variable named "WksRange" Set WksRange = Wks.Columns(Col1:=1, Col2:=2) Sleep(200) 'Remove first two columns of data (which were just selected with WksRange) WksRange.Cut 'Cut and paste column 3 into column 2 Set WksRange = Wks.Columns(Col1:=3, Col2:=3) Sleep(200) WksRange.Cut Set WksRange = Wks.Columns(Col1:=2, Col2:=2) Sleep(200) WksRange.Paste 'Cut and paste column 4 into column 1 Set WksRange = Wks.Columns(Col1:=4, Col2:=4) Sleep(200) WksRange.Cut Set WksRange = Wks.Columns(Col1:=1, Col2:=1) Sleep(200) WksRange.Paste 'Count the number of rows in the Data file Dim TotalRows As Integer TotalRows% = WksRange.RowCount 'Insert row at top of Data file Dim WksRangeRow As Object Set WksRangeRow = Wks.Rows(Row1:=1, Row2:=1) Sleep(200) WksRangeRow.Insert(Direction:=wksInsertDown) 'Put the total number of rows into the first cell Dim TotalRowsCell As Object Set TotalRowsCell = Wks.Cells("A1") TotalRowsCell.Value = TotalRows% 'Create the file name for the Blanking file to be created for the Cross Section Dim FileCrossSection As String FileCrossSection$ = Trim$(Directory) & "CrossSection" & ".bln" 'Save Data file as Blanking file (.bln) Wks.SaveAs(FileName:=FileCrossSection$) 'Close the active document SurferApp.ActiveDocument.Close 'Create graph for Cross Section 'Create Base Map for Cross Section Dim CrossSection As Object Set CrossSection = Shapes.AddBaseMap(ImportFileName:=FileCrossSection$) Dim CrossSectionMap As Object Set CrossSectionMap = CrossSection.Overlays(1) 'Add Post Map with BoundaryLine labels 'Add maximum value for Y in Cross Section to column 6 for graphing purposes (Y position) Dim Axes As Object Set Axes = CrossSection.Axes Dim MaxYAxis As Object Set MaxYAxis = Axes("left axis") Dim MaxYValue As Double MaxYValue# = MaxYAxis.Maximum Dim MaxElementalPercent As Object Set MaxElementalPercent = LabelWks.Cells(Row:=1, Col:=6, LastRow:=TotalPoints%, LastCol:=6) MaxElementalPercent.Value = MaxYValue# 'Close the active document SurferApp.ActiveDocument.Close Dim CrossLabelMap As Object Set CrossLabelMap = Shapes.AddPostMap(DataFileName:=FileBoundaryLabels$, xCol:=5, yCol:=6, LabCol:=3) Dim CrossLabelPostMap As Object Set CrossLabelPostMap = CrossLabelMap.Overlays(1) 'Formatting Post Map Dim CrossYMax As Double CrossYMax# = MaxYValue# + (0.05 * MaxYValue#) Dim CrossYMin As Double CrossYMin# = 0 - (0.01 * MaxYValue#) CrossLabelPostMap.LabelPos = srfPostPosUser CrossLabelPostMap.LabelYOffset = 0.04 '(inches) CrossLabelPostMap.LabelFont.Size = 12 CrossLabelPostMap.LabelFont.Color = srfColorWhite CrossLabelPostMap.LabelFont.Bold = True CrossLabelPostMap.Symbol.Set="GSI Default Symbols" CrossLabelPostMap.Symbol.Index = 21 CrossLabelPostMap.Symbol.Size = 0.32 CrossLabelPostMap.Symbol.Color = srfColorBlack 'Overlay Base Map with Post Map of Boundary line labels 'Select maps CrossSection.Selected = True CrossLabelMap.Selected = True 'Declares selected maps as object Dim SelectedMaps As Object 'Assigns the Selection collection to a variable named "SelectMaps" Set SelectedMaps = Plot.Selection 'Overlays the Image and Base Maps SelectedMaps.OverlayMaps 'Formatting combined Cross Section graph 'Setting dimensions CrossSection.SetLimits(xMin:=CrossXMin#, xMax:=CrossXMax#, yMin:=CrossYMin#, yMax:=CrossYMax#) 'Setting the X and Y axis scales CrossSection.xLength = 9 'Set X dimension CrossSection.yLength = 3.25 'Set Y dimension 'Label axes in Cross Section Dim XAxis As Object Set XAxis = Axes("bottom axis") 'Assigns the bottom X axis to the variable named "XAxis" XAxis.Title = "Distance Along Boundary Line (mm)" 'Adds title to bottom axis XAxis.TitleFont.Bold = True XAxis.TitleFont.Size = 14 Dim YAxis As Object Set YAxis = Axes("left axis") 'Assigns the left Y axis to the variable named "YAxis" YAxis.Title = ZLabel$(i) 'Add title to left axis YAxis.TitleFont.Bold = True YAxis.TitleFont.Size = 14 Dim TopAxis As Object Set TopAxis = Axes("top axis") TopAxis.AxisLine.Style = "Invisible" 'Remove the top axis 'Adjusting line on Cross Section CrossSectionMap.Line.ForeColor = srfColorBlack CrossSectionMap.Line.Width = 0.020 'Positioning map along bottom of page CrossSection.Left = .5 CrossSection.Top = 4.5 ''''''Save Surfer file and create JPEG 'Create the file name for the new plots created Dim FileSurf As String FileSurf$ = Trim$(Directory$) & Trim$(FileArray$(i)) & "_" & "CrossSection" & ".srf" 'Save the Surfer file of the plots created Plot.SaveAs(FileName:=FileSurf$) 'Create the file name for the JPG of the plots created Dim FileJPG As String FileJPG$ = Trim$(Directory$) & Trim$(FileArray$(i)) & "_" & "CrossSection" & ".jpg" 'Export the plots as a JPG file Plot.Export2(FileName:=FileJPG$, SelectionOnly:=False,Options:="Defaults=1, ForgetOptions=1, KeepAspect=1, Width=2048") 'Wait 3 secs Wait(3) 'Close the Surfer App SurferApp.Documents.CloseAll(SaveChanges:=srfSaveChangesNo) SurferApp.Quit 'Closing loop going through all the files Next i% astring$ = "All (.SRF, .JPG, etc) output was automatically saved to the " & Directory$ & " folder." MsgBox astring$, vbOkOnly + vbInformation, "OutputMapPage" End End Sub