Jump to content

Welcome to eMastercam

Register now to participate in the forums, access the download area, buy Mastercam training materials, post processors and more. This message will be removed once you have signed in.

Use your display name or email address to sign in:

be

Verified Members
  • Posts

    7
  • Joined

  • Last visited

Everything posted by be

  1. I updated the Script, works better. Has more functionality and more ways to safely exit.
  2. '//////////////////////////////////////////////////////////////////////////////// '// '// Author: Jesse T. '// Credits: Mick George [email protected] (I learned from his examples) '// Date: 06/2016 '// File Name: Fixture Plate Setup.vbs '// '// Description: This script Imports solids and moves them to fixture locations '// '//////////////////////////////////////////////////////////////////////////////// ' //////////////////// ' Constants ' //////////////////// Const ZZero = 0 Const Origin = 0 Const TopView = 1 ' -- Start Script Call Main() ' //////////////////// ' Sub Declaration ' //////////////////// Sub Main() ' //////////////////// ' Variables ' //////////////////// Dim intLevelNumber Dim iX, iY, SetDistX, SetDistY, intCountX, intCountY Dim File_or_Level Dim Sort_or_Center Dim SetAngle Dim NumParts ' -- Initialize SetAngle = 0 SetDistX = 2.0 SetDistY = 2.0 intCountX = 2 intCountY = 2 intLevelNumber = 2 NumParts = 0 ' -- Ask our user for some values File_or_Level = askYesNoCancel("This VB Script will help you set up multiple parts on a fixture plate."_ &VbCrLf&"""CANCEL"" if you want to exit this VBScript."_ &VbCrLf&"""NO"" if your parts are on seperate LEVELS and the file is already open"_ &VbCrLf&"""YES"" if your parts are in seperate FILES"_ &VbCrLf&VbCrLf&" FILES LEVELS CANCEL") If File_or_Level = 0 Then Sort_or_Center = askYesNoCancel("If you want to move your parts to center select ""YES"""_ &VbCrLf&"If you want to layout a fixture plate select ""No"""_ &VbCrLf&VbCrLf&" Parts NOT on center Parts on center CANCEL") End If If File_or_Level = -1 Then Exit Sub If Sort_or_Center = -1 Then Exit Sub If Sort_or_Center = mcMSG_NO Then If Not askValue("Do you have to rotate the part?", -360 , 360, SetAngle) Then Exit Sub End If If Not askNumber("How many Parts along the X axis?", 1 , 50, intCountX) Then Exit Sub If Not askNumber("How many parts along the Y axis?", 1 , 50, intCountY) Then Exit Sub If Not askValue("Input X spacing of Parts", 0 , 20, SetDistX) Then Exit Sub If Not askValue("Input Y spacing of Parts", 0 , 20, SetDistY) Then Exit Sub ' -- Do some math Redim Preserve arrPartPosX(intCountX*intCountY) Redim Preserve arrPartPosY(intCountX*intCountY) For iY = 0 To intCountY - 1 For iX = 0 To intCountX - 1 arrPartPosX(NumParts) = (iX * SetDistX)-(((intCountX-1)*SetDistX)/2) arrPartPosY(NumParts) = (-(iY * SetDistY))+(((intCountY-1)*SetDistY)/2) 'ShowString "Part# "& NumParts + 1 &" = "& arrPartPosX(NumParts)&", "&arrPartPosY(NumParts) NumParts = NumParts + 1 Next Next Call Run_Script (NumParts, arrPartPosX, arrPartPosY, intCountX, intCountY, intLevelNumber, File_or_Level, Sort_or_Center, SetAngle) End Sub ' //////////////////// ' The Sub that does it all ' //////////////////// Sub Run_Script (NumParts, arrPartPosX, arrPartPosY, intCountX, intCountY, intLevelNumber, File_or_Level, Sort_or_Center, SetAngle) Dim YLoc Dim XLoc Dim strLevelName Dim Revert_Back Redim Preserve arrLevelUsed(intCountX*intCountY) 'Loads files and translates into fixture locations If File_or_Level = mcMSG_YES And Sort_or_Center = mcMSG_NO Then ShowString "Please select a starting level, parts will load in sequential levels" If askLevel(intLevelNumber) Then ' -- Rotate and Position Parts For NumParts = 0 To (intCountX*intCountY) - 1 strLevelName = "Position #" & NumParts + 1 If mc_appversion < 19 Then 'Renames levels if MCam is older than 2017 Version Call SetLevelName (intLevelNumber, strLevelName) End If YLoc = arrPartPosY(NumParts) XLoc = arrPartPosX(NumParts) arrLevelUsed(NumParts) = intLevelNumber SetLevelVisibleByNumber intLevelNumber, False SelectAll() SetLevelByNumber (intLevelNumber) Call RepaintScreen(True) Call RunMastercamCommand ("DoPattern") SetLevelVisibleByNumber intLevelNumber,True Call RunMastercamCommand ("GSInvertSelection") If StartDBSearch(mc_selected, -1)= 0 Then NumParts = (intCountX*intCountY) - 1 Rotate Origin, Origin, Origin, SetAngle, False SetLevelVisibleByNumber intLevelNumber, False SelectAll() SetLevelByNumber (intLevelNumber) SetLevelVisibleByNumber intLevelNumber,True Call RunMastercamCommand ("GSInvertSelection") Call Move_to_location(XLoc, YLoc, NumParts) intLevelNumber = intLevelNumber + 1 Next End If End If ' -- Clear and Zoom All UnselectAll() Call RepaintScreen(True) Call ClearMenuAndPrompts 'Translates individual levels into fixture locations If File_or_Level = mcMSG_NO And Sort_or_Center = mcMSG_NO Then ' -- Rotate and Position Parts For NumParts = 0 To (intCountX*intCountY) - 1 intLevelNumber = intLevelNumber + 1 YLoc = arrPartPosY(NumParts) XLoc = arrPartPosX(NumParts) If askLevel(intLevelNumber) Then arrLevelUsed(NumParts) = intLevelNumber SetLevelVisibleByNumber intLevelNumber, False SelectAll() SetLevelByNumber (intLevelNumber) SetLevelVisibleByNumber intLevelNumber,True Call RunMastercamCommand ("GSInvertSelection") Rotate Origin, Origin, Origin, SetAngle, False SetLevelVisibleByNumber intLevelNumber, False SelectAll() SetLevelByNumber (intLevelNumber) SetLevelVisibleByNumber intLevelNumber,True Call RunMastercamCommand ("GSInvertSelection") Call Move_to_location(XLoc, YLoc, NumParts) End If Next End If ' -- Clear and Zoom All UnselectAll() Call RepaintScreen(True) Call ClearMenuAndPrompts '---- Unsorts individual parts to center If Sort_or_Center = mcMSG_YES Then For NumParts = 0 To (intCountX*intCountY) - 1 YLoc = -arrPartPosY(NumParts) XLoc = -arrPartPosX(NumParts) If AskForEntity("SELECT PART #"&numparts+1,-1) Then arrLevelUsed(NumParts) = GetEntityLevel() Call Move_to_location(XLoc, YLoc, NumParts) Rotate Origin, Origin, Origin, - SetAngle, False End If Next End If ' -- Clear and Zoom All UnselectAll() Call RepaintScreen(True) Call ClearMenuAndPrompts Revert_Back = askYesNo("Do you want to keep these new locations?") '---- Reverses Translated individual levels back to original locations If Revert_Back = mcMSG_NO Then For NumParts = 0 To (intCountX*intCountY) - 1 intLevelNumber = arrLevelUsed(NumParts) If Sort_or_Center = mcMSG_YES Then YLoc = arrPartPosY(NumParts) XLoc = arrPartPosX(NumParts) Else YLoc = -arrPartPosY(NumParts) XLoc = -arrPartPosX(NumParts) End If SetLevelVisibleByNumber intLevelNumber, False SelectAll() SetLevelByNumber (intLevelNumber) SetLevelVisibleByNumber intLevelNumber,True Call RunMastercamCommand ("GSInvertSelection") Call Move_to_location(XLoc, YLoc, NumParts) SetLevelVisibleByNumber intLevelNumber, False SelectAll() SetLevelByNumber (intLevelNumber) SetLevelVisibleByNumber intLevelNumber,True Call RunMastercamCommand ("GSInvertSelection") Rotate Origin, Origin, Origin, - SetAngle, False Next End If ' -- Clear and Zoom All UnselectAll() Call RepaintScreen(True) Call ClearMenuAndPrompts If askYesNo("Repeat the same setup?") = mcMSG_YES Then Call Run_Script (NumParts, arrPartPosX, arrPartPosY, intCountX, intCountY, intLevelNumber, File_or_Level, Sort_or_Center, SetAngle) End If End Sub ' //////////////////// ' Sub Declaration ' //////////////////// Sub Move_to_location(XLoc, YLoc, NumParts) Const DEF_GIVE_ME_EVERYTHING = -1 Dim bRet bRet = StartDBSearch(mc_selected, DEF_GIVE_ME_EVERYTHING) If bRet Then Do ' Change the location of each "selected" entity that we find. Call Translate (Origin, Origin, Origin, XLoc, YLoc, ZZero, TopView, TopView, False) bRet = NextDBSearch Loop While bRet End If ' Like it says... UnselectAll() End Sub I accidental deleted my original post. Here is an updated version that has more options. (This one works MUCH better). This script will sort or un-sort parts into a grid so they can be cut on a fixture plate. The reason I made this is because we typically get .X_T files of several parts that are pretty much the same except for cavity numbers or stacking lugs. Sometimes we'll get a single file with each part on it's own level, other times we'll get each individual part in it's own .X_t file. I feel I don't contribute enough to this forum to make up for how much help I've received. Hopefully this script will help someone else out. Just copy and paste the code into a text file and save that file as "Fixture Plate Setup.vbs" then run within MasterCam.
  3. Are all your planes set to the same WCS?
  4. HI Mick BTW, thanks for all your help on the Script! I've made a lot of changes since you last saw it, but learned a lot from what you had before I fiddled with it. I can't seem to figure out how to get the script to create a setup sheet according to each individual machine group. The tools get recorded from all the operations in the program, but it seems to be random as to which of the tools it decides to record. An example would be if I have two machine groups (each of which have a different NCI file name), but I have T1 as a 3/4" ST in the first machine group and T1 is a 1/2" SB in the second machine group. I'm never sure which one is going to be output to the setup sheet.
  5. Unfortunately MasterCam only gives one set of information for each tool number for me to use in the VB Script. I end up deleting the machine group I don't want, creating my setup sheet and re-opening the MasterCam file without saving the modified one. The Active Reports setup sheet that some people in our shop use also seems to have the same problem. I personally don't like the Active Reports setup sheet since I can't modify the HTML file after it was created and the tool list is displayed out of order if the tools were used out of order in the program. If I accidentally have a tool length wrong I'd have to make the change to the tool and wait for all the segments to regenerate (when using dovetail cutters with Surface/finish/contour this can take a while). Then I have to re-create the setup sheet. I wish I had a better solution. In older versions of MasterCam, the VB Script pulled in the info from whatever Machine group was active, not sure why this went away.
  6. So..... I've been obsessing over the VB setup sheet since I "took it over" from John to tweek problems and add functions. One of these "updates" is so that I don't have to re-type all the information for each setup sheet when I have multiple parts for the same job. Not sure how many people will use this but here it is. Please give some feedback if you use it. '//////////////////////////////////////////////////////////////////////////////// '// '// Author: Jesse Thering, John Thompson, and with MUCH help from Mick George and Bullines! '// Date: 02/09/2015 '// File Name: New Mastercam Script '// '// Description: Setupsheet.vbs setup sheet '// '// Comments: Job Setup Doc sheet '// '//////////////////////////////////////////////////////////////////////////////// '///////////////// My Constants ///////////////// '///////////////// My Global Variables ////////// ' -- Start Script ' //////////////////// ' Sub Declaration ' //////////////////// Dim wordDoc '///////////////// My Constants ///////////////// Dim companyname Dim Program Dim Description Dim Post Dim PostName Dim programmer Dim notes Dim tlo Dim whatever Dim thisstring Dim nCount ' number of operations Dim nToolNum ' tool number Dim arrToolNumber() ' array of tool numbers Dim arrToolComment() ' array of tool comments Dim arrToolDiameter() ' array of tool diameters Dim arrToolFluteLength() ' array of tool flute lengths Dim arrToolLength() ' array of tool lengths Dim arrOperationType() ' array to store the operation type, Drill = 2, Pocket = 3, transformed operation = 4 dim arrtools(24) Dim idx Dim toolcount Dim strText Dim Position Dim FileName Dim graphic Dim stockx Dim stocky Dim stockz Dim material Dim saveworddoc dim blah dim tn dim tdesc dim tdiam dim tflute Dim toverall Dim CompanyChar 'Number of characters in company name Dim DescChar 'Number of characters in Description Dim FileChar 'Number of Characters in Filename Dim PIC Dim LastDotPos Const wdTabLeaderSpaces = 0 Dim DateTimeFormat() Const wdAlertsNone=0 Const wdWindowStateMaximize=1 Const wdLine=5 Const wdEnglishUS = 1033 Const wdCalendarWestern = 0 Const wdColorDarkRed=128 Const wdAlignParagraphCenter=1 Const msoTextOrientationHorizontal = 1 Const wdTextOrientationDownward = 3 Const msoFalse=0 Const DEF_SPACING_ONEANDAHALF=1 Const DEF_SPACING_ONE=0 Const wdAlignTabRight = 2 Const wdAlignTabLeft=2 Const Clip_Board="clipbrd" '///////////////// My Global Variables ////////// ' -- Start Script Call Main() ' //////////////////// ' Sub Declaration ' //////////////////// Sub Main() On Error Resume Next '///////////////// Extract info Constants ///////////////// Dim CurrentFolder Dim strDOCPath Dim OldJobInfo Dim txtBoxTwo Dim txtBoxFive Dim arrBoxTwo Dim arrBoxFive Dim strCompany Dim arrCompany Dim strDesc Dim arrDesc Dim strPartNum Dim arrPartNum Dim strName Dim arrName Const ConfirmConversions = 0 Const Readonly = 1 Const AddToRecentFiles = 0 Const Revert = True Const wdDoNotSaveChanges = 0 'If extract info= yes, pull info from old setup sheet If askYesNo ("Do you want to extract job info from a previous setup sheet?")=mcMSG_YES Then OldJobInfo=1 End If If OldJobInfo=1 Then CurrentFolder = Left(GetCurrentFileName(),InStrRev(GetCurrentFileName(),"\")) FileName= CurrentFolder & ".DOC*" If Not (AskForFileName(FileName, mcFILE_ACCESS_READ, strDOCPath)) Then ' Prompt the user for a DOC file. Bail if the user cancels the dialog. ShowString("No file selected") Exit Sub End If Set WordDoc = CreateObject( "Word.Application" ) wordDoc.Documents.Open strDOCPath,ConfirmConversions,Readonly,AddToRecentFiles, , ,Revert With WordDoc .Visible = False .ActiveDocument.Shapes.Range(2).Select .ActiveDocument.Select txtBoxTwo=.Selection .ActiveDocument.Shapes.Range(5).Select .ActiveDocument.Select txtBoxFive=.Selection .ActiveDocument.Close wdDoNotSaveChanges .Quit Set wordDoc = Nothing End With End If 'Pull info from individual fields arrBoxTwo = Split(txtBoxTwo, vbCr) 'Breaks information txt boxes into seperate lines arrBoxFive = Split(txtBoxFive, vbCr) arrCompany = Split(arrBoxTwo(0), vbTab) 'extracts company name strCompany = arrCompany(1) If Err.Number = 0 Then ' Successfully extracted company name Else ' Maybe someone deleted the Tab? strCompany = Replace(arrBoxTwo(0),"Company: ","") End If Err.Number = 0 'whatever=AskString("Company", strCompany) arrDesc = Split(arrBoxTwo(1), vbTab) 'extracts Description strDesc = arrDesc(1) If Err.Number = 0 Then ' Successfully extracted Description Else ' Maybe someone deleted the Tab? strDesc = Replace(arrBoxTwo(1),"Description: ","") End If Err.Number = 0 arrPartNum = Split(arrBoxTwo(2), vbTab) 'extracts Part Number strPartNum =arrPartNum(1) If Err.Number = 0 Then ' Successfully extracted Part Number Else ' Maybe someone deleted the Tab? strPartNum = Replace(arrBoxTwo(2),"Part Num: ","") End If Err.Number = 0 arrName = Split(arrBoxFive(0), vbTab) 'extracts Programmer name strName = Replace(arrName(0),"Name: ","") '//////////////////////////////////////////////////////////////////////////////////////////////// 'Gather Info from user Do companyname=AskString("Input a company name", strCompany) 'ask until a real company name is entered Loop While companyname="Company Name?" Or companyname="((ESC))" Or companyname="" CompanyChar = Len (companyname) Do 'ask until a real program number is used Program=AskString("Part Number?", strPartNum) Loop While Program="Part Number?" Or Program="" Or Program="((ESC))" Do 'ask until a real description is used Description=AskString("Description", strDesc) Loop While Description="description" Or Description="" Or Description="((ESC))" DescChar = Len (Description) Post=AskString("Post", Left(Mid(Mid(GetPostName(), InStrRev(GetPostName(), "/") + 1), InStrRev(GetPostName(), "\") + 1),_ InStrRev(Mid(Mid(GetPostName(), InStrRev(GetPostName(), "/") + 1), InStrRev(GetPostName(), "\") + 1),".")-1)) Do 'ask until a real programmer name is input programmer=AskString("Programmer?", strName) Loop While programmer="programmer?" Or programmer="" Or programmer="((ESC))" notes=AskString("Notes", "") If notes="Notes" Or notes="" Then notes="" End If Do tlo=AskString("TL0", "TOS") Loop While tlo="TL0" Or tlo="" Or tlo="((ESC))" 'get stock setup sizes stockx=GetJobSetupStockSizeX stocky=GetJobSetupStockSizeY stockz=GetJobSetupStockSizeZ Do material=AskString("Material type?", "Aluminum") Loop While material="NONE" Or material="" Or material="Material type?" 'check stock size for 0 If stockx=0 Then If askYesNo ("Stock size is zero, do you want to change it?")=mcMSG_YES Then stockx=AskString ("X stock size?", "") stocky=AskString ("Y stock size?", "") stockz=AskString ("Z stock size", "") End If End If 'Load tool information ' get the number of operations nCount = GetOperationCount("") If nCount = 0 Then ShowString "No operations found in current drawing": Exit Sub Dim id dim tc dim doit Dim temp whatever="" For idx = 0 To nCount-1 ' get the tool number using the current operation nToolNum = GetToolNumberFromOperationID("", idx) whatever=formatnumber(idx) Redim Preserve arrToolNumber(idx) Redim Preserve arrToolComment(idx) Redim Preserve arrToolDiameter(idx) Redim Preserve arrToolFluteLength(idx) Redim Preserve arrToolLength(idx) Redim Preserve arrOperationType(idx) arrOperationType(idx) = GetOperationTypeFromID("", idx) ' copy tool data into our individual arrays arrToolNumber(idx) = nToolNum Next ' Sort Tools in ascending order For idx = 0 To Ubound(arrToolNumber) - 1 For temp = idx + 1 To Ubound(arrToolNumber) If (arrToolNumber(idx) > arrToolNumber(temp)) Then TN = arrToolNumber(idx) arrToolNumber(idx) = arrToolNumber(temp) arrToolNumber(temp) = TN End If Next Next ' copy tool data into our individual arrays For idx = 0 To nCount-1 nToolNum = arrToolNumber(idx) arrToolComment(idx) = GetToolComment(nToolNum) arrToolDiameter(idx) = GetToolDiameter(nToolNum) arrToolFluteLength(idx) = GetToolFluteLength(nToolNum) arrToolLength(idx) = GetToolLength(nToolNum) Next 'Save number of characters in Filename FileChar = Len (GetCurrentFileName()) 'open word Set wordDoc=CreateObject("Word.Application") wordDoc.Documents.Add With wordDoc .Visible=True .WindowState=wdWindowStateMaximize .DisplayAlerts=wdAlertsNone .Activate 'Sets Margins .Selection.PageSetup.LeftMargin = .InchesToPoints(0.5) 'start of margin setting macro .Selection.PageSetup.RightMargin = .InchesToPoints(0.5) .Selection.PageSetup.TopMargin = .InchesToPoints(0.5) .ActiveWindow.ActivePane.VerticalPercentScrolled = 20 .Selection.PageSetup.BottomMargin = .InchesToPoints(0.5) 'end of margin setting macro .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 'Puts "Program Info" top center .Selection.Font.Bold=True .Selection.Font.Size=16 .Selection.ParagraphFormat.Alignment=wdAlignParagraphCenter .Selection.Font.Name="staccato222 BT" .Selection.TypeText "PROGRAM INFO" .Selection.TypeText vbNewLine 'Puts program number in sideways box, right side .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 525, 75, 45, 117).Select 'start of macro code .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse .Selection.ShapeRange.Select .Selection.ShapeRange.IncrementLeft 36 .Selection.ShapeRange.IncrementTop -18 .Selection.Orientation = wdTextOrientationDownward .Selection.Font.Size = 24 .Selection.Font.Name="Times New Roman" .Selection.TypeText Program 'double text boxes for header info .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20,70, 222.3, 60).Select 'first box left side .Selection.ShapeRange.TextFrame.TextRange.Select 'First box header info goes this section .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.Font.Size = 12 .Selection.TypeText "Company: "&vbTab 'Company Name If CompanyChar > 21 Then .Selection.Font.Size = 10 Else If CompanyChar <= 21 Then .Selection.Font.Size = 12 End If End If .Selection.Font.Bold=False .Selection.TypeText companyname&vbNewLine .Selection.Font.Size = 12 .Selection.Font.Bold=True .Selection.TypeText "Description: "&vbTab 'Description If DescChar > 21 Then .Selection.Font.Size = 10 If DescChar > 26 Then .Selection.Font.Size = 9 Else If DescChar <= 21 Then .Selection.Font.Size = 12 End If End If End If .Selection.Font.Bold=False .Selection.TypeText Description &vbNewLine .Selection.Font.Size = 12 .Selection.Font.Bold=True .Selection.TypeText "Part Num: "&vbTab 'Part number .Selection.Font.Bold=False .Selection.TypeText Program &vbNewLine .Selection.Font.Bold=True .Selection.Font.Bold=True .Selection.TypeText "Material: "&vbTab 'Material type .Selection.Font.Bold=False .Selection.TypeText material &vbNewLine 'Second Header box .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 245,70, 320, 60).Select 'second box right side .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse If FileChar >= 48 Then .Selection.Font.Size = 9 Else If FileChar < 48 Then .Selection.Font.Size = 12 End If End If .Selection.Font.Bold=True .Selection.TypeText "Filename: " 'File Name If FileChar <= 28 Then .Selection.TypeText vbTab&vbTab End If If FileChar > 34 Then .Selection.Font.Size = 10 If FileChar >= 40 Then .Selection.Font.Size = 9 If FileChar >= 44 Then .Selection.Font.Size = 8 Else If FileChar <= 34 Then .Selection.Font.Size = 12 End If End If End If End If .Selection.Font.Bold=False .Selection.TypeText GetCurrentFileName()&vbNewLine .Selection.Font.Size = 12 .Selection.Font.Bold=True .Selection.TypeText "Post: "&vbTab&vbTab&vbTab 'Post .Selection.Font.Bold=False .Selection.TypeText Post &vbNewLine .Selection.Font.Bold=True .Selection.TypeText "Stock Size: "&vbTab&vbTab 'Stock size IF in job setup .Selection.Font.Bold=False .Selection.TypeText "X"&stockx&" Y"&stocky&" Z"&stockz &vbNewLine .Selection.Font.Bold=True .Selection.TypeText "Stock Origin: "&vbTab 'Stock origin from job setup. Almost always 0,0 .Selection.Font.Bold=False .Selection.TypeText "X"& GetJobSetupStockOriginX&" Y"& GetJobSetupStockOriginY&" (On Center)"&vbNewLine 'Print out notes .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 130, 530, 35).Select .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "NOTES: " .Selection.Font.Bold=False .Selection.TypeText notes 'Revisions listing .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 168, 575.7, 36).Select .ActiveDocument.Paragraphs.TabStops.ClearAll .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(1.6) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(3.1) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(4.6) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(6.1) .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible=msoFalse .Selection.Font.Bold=True .Selection.TypeText "Name: "&programmer&vbTab&"Name:________"&vbTab&"Name:________"&vbTab&"Name:_______"&vbTab&"Name:________"&vbNewLine .Selection.TypeText "Date: " 'Date .Selection.InsertDateTime "M/D/YY", False, False, wdEnglishUS, wdCalendarWestern 'get the date .Selection.TypeText vbTab&"Date:________"&vbTab&"Date:________"&vbTab&"Date:_______"&vbTab&"Date:________" 'puts out tool list 'creat 2 text boxes 'left side box .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 213, 270, 225).Select .ActiveDocument.Paragraphs.TabStops.ClearAll .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(.4) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(1.75) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(2.375) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(3) .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONEANDAHALF .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "Tool"&vbTab&"Description"&vbTab&" "&"Dia "&vbTab&"Flute"&vbTab&"Overall" .Selection.Font.Bold=False toolcount=1 For idx=0 To nCount-1 If toolcount<=10 Then strText = "Transformed operation copy" tdesc=Left(arrToolComment(idx),17) tdiam=formatnumber(arrToolDiameter(idx),3,0,-2,-2) tflute=formatnumber(arrToolFluteLength(idx),2,0,-2,-2) toverall=formatnumber(arrToolLength(idx),2,0,-2,-2) strText="T"&arrToolNumber(idx)&vbTab&tdesc&vbTab&" " &tdiam &vbTab&" "&tflute &vbTab&toverall thisstring="Left "&formatnumber(idx)&" " & arrtoolnumber(idx) 'whatever=AskString(thisstring, strText) doit="y" for tc=1 to toolcount If arrtools(tc)=arrtoolnumber(idx) Then doit="n" next If arrtoolnumber(idx)="0" Then doit="n" if doit<>"n" then Call WriteToWord(strText) arrtools(toolcount)=arrtoolnumber(idx) If doit<>"n" Then toolcount=toolcount+1 End If Next 'Right side box .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 310, 213, 270, 225).Select .ActiveDocument.Paragraphs.TabStops.ClearAll .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(.4) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(1.75) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(2.375) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(3) .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONEANDAHALF .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "Tool"&vbTab&"Description"&vbTab&" "&"Dia"&vbTab&"Flute"&vbTab&"Overall" .Selection.Font.Bold=False 'Second column of tools toolcount=1 For idx=0 To nCount-1 strText = "Transformed operation copy" tdesc=Left(arrToolComment(idx),17) tdiam=formatnumber(arrToolDiameter(idx),3,0,-2,-2) tflute=formatnumber(arrToolFluteLength(idx),2,0,-2,-2) toverall=formatnumber(arrToolLength(idx),2,0,-2,-2) strText = "T"&arrToolNumber(idx)& vbTab & _ tdesc & vbTab &" " & _ tdiam & vbTab&" "& _ tflute &vbTab& _ toverall 'whatever=AskString(thisstring, strText) doit="y" For tc=1 To toolcount If arrtools(tc)=arrtoolnumber(idx) Then doit="n" Next If arrtoolnumber(idx)="0" Then doit="n" If doit<>"n" And toolcount>= 10 Then Call WriteToWord(strText) arrtools(toolcount)=arrtoolnumber(idx) If doit<>"n" Then toolcount=toolcount+1 Next 'Put TL0 information in .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 445, 564.3, 35).Select .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Select .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "T.L.0. Location: " .Selection.Font.Bold=False .Selection.TypeText tlo&vbNewLine .Selection.TypeText "_________________________________________________________________________________________" 'Check for "temp" directory Dim fso, fldr, objFolder Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists("C:\temp") Then Set fldr = fso.CreateFolder("C:\temp") Set objFolder = fso.getFolder("C:\temp") objFolder.Attributes = 2 End If 'Load Graphic into textbox Call SetGViewNumber (mcVIEW_TOP) ' Top view picture Call RepaintScreen (True) ' that is centered graphic="c:\temp\test.emf" DoMetafile graphic .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 115, _ 480, 390, 302).Select .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse Set PIC = .Selection.InlineShapes.AddPicture (graphic,False,True) PIC.LockAspectRatio = True Dim Aspect Aspect = PIC.Width / PIC.Height If (PIC.Width > 520) Then PIC.Width = 520 PIC.Height = PIC.Width / Aspect ElseIf (PIC.Height > 260) Then PIC.Height = 260 PIC.Width = PIC.Height * Aspect End If 'save word document to same directory as MC file 'removes file extension LastDotPos = InStrRev(GetCurrentFileName(),".") Filename = Left(GetCurrentFileName(),LastDotPos-1) On Error Resume Next saveworddoc = Filename & ".DOC" 'ShowString(saveworddoc) .ActiveDocument.SaveAs saveworddoc If Err.Number = 0 Then ' Successfully Saved file Else ' Save file failed ShowString "Cannot Save File, File Already Open "&saveworddoc: Exit Sub End If End With 'end output to word On Error Goto 0 If Not wordDoc Is Nothing Then Set wordDoc = Nothing ShowString "Setup Sheet Finished"&vbNewLine&"file saved as "&saveworddoc End Sub ' Writes tool list to word Public Sub WriteToWord(strOutText) Dim wordCounts With wordDoc .Selection.MoveDown wdLine, .ActiveDocument.Words.Count .Selection.TypeParagraph .Selection.TypeText strOutText End With End Sub
  7. I have a VB script you could try. You'll need Microsoft office to use it. '//////////////////////////////////////////////////////////////////////////////// '// '// Author: Jesse Thering, John Thompson, and with MUCH help from Mick George and Bullines! '// Date: 02/09/2015 '// File Name: New Mastercam Script '// '// Description: Setupsheet.vbs setup sheet '// '// Comments: Job Setup Doc sheet '// '//////////////////////////////////////////////////////////////////////////////// '///////////////// My Constants ///////////////// '///////////////// My Global Variables ////////// ' -- Start Script ' //////////////////// ' Sub Declaration ' //////////////////// Dim wordDoc '///////////////// My Constants ///////////////// Dim companyname Dim Program Dim Description Dim Post Dim programmer Dim notes Dim tlo Dim nCount ' number of operations Dim nToolNum ' tool number Dim arrToolNumber() ' array of tool numbers Dim arrToolComment() ' array of tool comments Dim arrToolDiameter() ' array of tool diameters Dim arrToolFluteLength() ' array of tool flute lengths Dim arrToolLength() ' array of tool lengths Dim arrOperationType() ' array to store the operation type, Drill = 2, Pocket = 3, transformed operation = 4 dim arrtools(24) Dim idx Dim toolcount Dim strText Dim Position Dim FileName Dim graphic Dim stockx Dim stocky Dim stockz Dim material Dim saveworddoc dim blah dim tn dim tdesc dim tdiam dim tflute Dim toverall Dim CompanyChar 'Number of characters in company name Dim DescChar 'Number of characters in Description Dim FileChar 'Number of Characters in Filename Dim PIC Const wdTabLeaderSpaces = 0 Dim DateTimeFormat() Const wdAlertsNone=0 Const wdWindowStateMaximize=1 Const wdLine=5 Const wdEnglishUS = 1033 Const wdCalendarWestern = 0 Const wdColorDarkRed=128 Const wdAlignParagraphCenter=1 Const msoTextOrientationHorizontal = 1 Const wdTextOrientationDownward = 3 Const msoFalse=0 Const DEF_SPACING_ONEANDAHALF=1 Const DEF_SPACING_ONE=0 Const wdAlignTabRight = 2 Const wdAlignTabLeft=2 Const Clip_Board="clipbrd" '///////////////// My Global Variables ////////// ' -- Start Script Call Main() ' //////////////////// ' Sub Declaration ' //////////////////// Sub Main() 'On Error Resume Next Do 'ask until a real company name is entered companyname=AskString("Input a company name", "") Loop While companyname="Company Name?" Or companyname="((ESC))" Or companyname="" CompanyChar = Len (companyname) Do 'ask until a real program number is used Program=AskString("Part Number?", "") Loop While Program="Part Number?" Or Program="" Or Program="((ESC))" Do 'ask until a real description is used Description=AskString("Description", "") Loop While Description="description" Or Description="" Or Description="((ESC))" DescChar = Len (Description) Post=AskString("Post", "Fadal") Do 'ask until a real programmer name is input programmer=AskString("Programmer?", "") Loop While programmer="programmer?" Or programmer="" Or programmer="((ESC))" notes=AskString("Notes", "") If notes="Notes" Or notes="" Then notes="" End If Do tlo=AskString("TL0", "TOS") Loop While tlo="TL0" Or tlo="" Or tlo="((ESC))" 'get stock setup sizes stockx=GetJobSetupStockSizeX stocky=GetJobSetupStockSizeY stockz=GetJobSetupStockSizeZ Do material=AskString("Material type?", "Aluminum") Loop While material="NONE" Or material="" Or material="Material type?" 'check stock size for 0 If stockx=0 Then If askYesNo ("Stock size is zero, do you want to change it?")=mcMSG_YES Then stockx=AskString ("X stock size?", "") stocky=AskString ("Y stock size?", "") stockz=AskString ("Z stock size", "") End If End If 'Load tool information ' get the number of operations nCount = GetOperationCount("") If nCount = 0 Then ShowString "No operations found in current drawing": Exit Sub Dim id dim whatever dim thisstring dim tc dim doit Dim temp whatever="" For idx = 0 To nCount-1 ' get the tool number using the current operation nToolNum = GetToolNumberFromOperationID("", idx) whatever=formatnumber(idx) Redim Preserve arrToolNumber(idx) Redim Preserve arrToolComment(idx) Redim Preserve arrToolDiameter(idx) Redim Preserve arrToolFluteLength(idx) Redim Preserve arrToolLength(idx) Redim Preserve arrOperationType(idx) arrOperationType(idx) = GetOperationTypeFromID("", idx) ' copy tool data into our individual arrays arrToolNumber(idx) = nToolNum Next ' Sort Tools in ascending order For idx = 0 To Ubound(arrToolNumber) - 1 For temp = idx + 1 To Ubound(arrToolNumber) If (arrToolNumber(idx) > arrToolNumber(temp)) Then TN = arrToolNumber(idx) arrToolNumber(idx) = arrToolNumber(temp) arrToolNumber(temp) = TN End If Next Next ' copy tool data into our individual arrays For idx = 0 To nCount-1 nToolNum = arrToolNumber(idx) arrToolComment(idx) = GetToolComment(nToolNum) arrToolDiameter(idx) = GetToolDiameter(nToolNum) arrToolFluteLength(idx) = GetToolFluteLength(nToolNum) arrToolLength(idx) = GetToolLength(nToolNum) Next 'Save number of characters in Filename FileChar = Len (GetCurrentFileName()) 'open word Set wordDoc=CreateObject("Word.Application") wordDoc.Documents.Add With wordDoc .Visible=True .WindowState=wdWindowStateMaximize .DisplayAlerts=wdAlertsNone 'Sets Margins .Selection.PageSetup.LeftMargin = .InchesToPoints(0.5) 'start of margin setting macro .Selection.PageSetup.RightMargin = .InchesToPoints(0.5) .Selection.PageSetup.TopMargin = .InchesToPoints(0.5) .ActiveWindow.ActivePane.VerticalPercentScrolled = 20 .Selection.PageSetup.BottomMargin = .InchesToPoints(0.5) 'end of margin setting macro .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 'Puts "Program Info" top center .Selection.Font.Bold=True .Selection.Font.Size=16 .Selection.ParagraphFormat.Alignment=wdAlignParagraphCenter .Selection.Font.Name="staccato222 BT" .Selection.TypeText "PROGRAM INFO" .Selection.TypeText vbNewLine 'Puts program number in sideways box, right side .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 525, 75, 45, 117).Select 'start of macro code .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse .Selection.ShapeRange.Select .Selection.ShapeRange.IncrementLeft 36 .Selection.ShapeRange.IncrementTop -18 .Selection.Orientation = wdTextOrientationDownward .Selection.Font.Size = 24 .Selection.Font.Name="Times New Roman" .Selection.TypeText Program 'double text boxes for header info .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20,70, 222.3, 60).Select 'first box left side .Selection.ShapeRange.TextFrame.TextRange.Select 'First box header info goes this section .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.Font.Size = 12 .Selection.TypeText "Company: "&vbTab 'Company Name If CompanyChar > 21 Then .Selection.Font.Size = 10 Else If CompanyChar <= 21 Then .Selection.Font.Size = 12 End If End If .Selection.Font.Bold=False .Selection.TypeText companyname&vbNewLine .Selection.Font.Size = 12 .Selection.Font.Bold=True .Selection.TypeText "Description: "&vbTab 'Description If DescChar > 21 Then .Selection.Font.Size = 10 If DescChar > 26 Then .Selection.Font.Size = 9 Else If DescChar <= 21 Then .Selection.Font.Size = 12 End If End If End If .Selection.Font.Bold=False .Selection.TypeText Description &vbNewLine .Selection.Font.Size = 12 .Selection.Font.Bold=True .Selection.TypeText "Part Num: "&vbTab 'Part number .Selection.Font.Bold=False .Selection.TypeText Program &vbNewLine .Selection.Font.Bold=True .Selection.Font.Bold=True .Selection.TypeText "Material: "&vbTab 'Material type .Selection.Font.Bold=False .Selection.TypeText material &vbNewLine 'Second Header box .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 245,70, 320, 60).Select 'second box right side .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse If FileChar >= 48 Then .Selection.Font.Size = 9 Else If FileChar < 48 Then .Selection.Font.Size = 12 End If End If .Selection.Font.Bold=True .Selection.TypeText "Filename: " 'File Name If FileChar <= 28 Then .Selection.TypeText vbTab&vbTab End If If FileChar > 34 Then .Selection.Font.Size = 10 If FileChar >= 40 Then .Selection.Font.Size = 9 If FileChar >= 44 Then .Selection.Font.Size = 8 Else If FileChar <= 34 Then .Selection.Font.Size = 12 End If End If End If End If .Selection.Font.Bold=False .Selection.TypeText GetCurrentFileName()&vbNewLine .Selection.Font.Size = 12 .Selection.Font.Bold=True .Selection.TypeText "Post: "&vbTab&vbTab&vbTab 'Post .Selection.Font.Bold=False .Selection.TypeText Post &vbNewLine .Selection.Font.Bold=True .Selection.TypeText "Stock Size: "&vbTab&vbTab 'Stock size IF in job setup .Selection.Font.Bold=False .Selection.TypeText "X"&stockx&" Y"&stocky&" Z"&stockz &vbNewLine .Selection.Font.Bold=True .Selection.TypeText "Stock Origin: "&vbTab 'Stock origin from job setup. Almost always 0,0 .Selection.Font.Bold=False .Selection.TypeText "X"& GetJobSetupStockOriginX&" Y"& GetJobSetupStockOriginY&" (On Center)"&vbNewLine 'Print out notes .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 130, 530, 35).Select .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "NOTES: " .Selection.Font.Bold=False .Selection.TypeText notes 'Revisions listing .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 168, 575.7, 36).Select .ActiveDocument.Paragraphs.TabStops.ClearAll .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(1.6) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(3.1) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(4.6) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(6.1) .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible=msoFalse .Selection.Font.Bold=True .Selection.TypeText "Name: "&programmer&vbTab&"Name:________"&vbTab&"Name:________"&vbTab&"Name:_______"&vbTab&"Name:________"&vbNewLine .Selection.TypeText "Date: " 'Date .Selection.InsertDateTime "M/D/YY", False, False, wdEnglishUS, wdCalendarWestern 'get the date .Selection.TypeText vbTab&"Date:________"&vbTab&"Date:________"&vbTab&"Date:_______"&vbTab&"Date:________" 'puts out tool list 'creat 2 text boxes 'left side box .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 213, 270, 225).Select .ActiveDocument.Paragraphs.TabStops.ClearAll .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(.4) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(1.75) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(2.375) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(3) .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONEANDAHALF .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "Tool"&vbTab&"Description"&vbTab&" "&"Dia "&vbTab&"Flute"&vbTab&"Overall" .Selection.Font.Bold=False toolcount=1 For idx=0 To nCount-1 If toolcount<=10 Then strText = "Transformed operation copy" tdesc=Left(arrToolComment(idx),17) tdiam=formatnumber(arrToolDiameter(idx),3,0,-2,-2) tflute=formatnumber(arrToolFluteLength(idx),2,0,-2,-2) toverall=formatnumber(arrToolLength(idx),2,0,-2,-2) strText="T"&arrToolNumber(idx)&vbTab&tdesc&vbTab&" " &tdiam &vbTab&" "&tflute &vbTab&toverall thisstring="Left "&formatnumber(idx)&" " & arrtoolnumber(idx) 'whatever=AskString(thisstring, strText) doit="y" for tc=1 to toolcount If arrtools(tc)=arrtoolnumber(idx) Then doit="n" next If arrtoolnumber(idx)="0" Then doit="n" if doit<>"n" then Call WriteToWord(strText) arrtools(toolcount)=arrtoolnumber(idx) If doit<>"n" Then toolcount=toolcount+1 End If Next 'Right side box .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 310, 213, 270, 225).Select .ActiveDocument.Paragraphs.TabStops.ClearAll .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(.4) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(1.75) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(2.375) .Selection.ParagraphFormat.TabStops.Add .InchesToPoints(3) .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONEANDAHALF .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "Tool"&vbTab&"Description"&vbTab&" "&"Dia"&vbTab&"Flute"&vbTab&"Overall" .Selection.Font.Bold=False 'Second column of tools toolcount=1 For idx=0 To nCount-1 strText = "Transformed operation copy" tdesc=Left(arrToolComment(idx),17) tdiam=formatnumber(arrToolDiameter(idx),3,0,-2,-2) tflute=formatnumber(arrToolFluteLength(idx),2,0,-2,-2) toverall=formatnumber(arrToolLength(idx),2,0,-2,-2) strText = "T"&arrToolNumber(idx)& vbTab & _ tdesc & vbTab &" " & _ tdiam & vbTab&" "& _ tflute &vbTab& _ toverall 'whatever=AskString(thisstring, strText) doit="y" For tc=1 To toolcount If arrtools(tc)=arrtoolnumber(idx) Then doit="n" Next If arrtoolnumber(idx)="0" Then doit="n" If doit<>"n" And toolcount>= 10 Then Call WriteToWord(strText) arrtools(toolcount)=arrtoolnumber(idx) If doit<>"n" Then toolcount=toolcount+1 Next 'Put TL0 information in .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 20, 445, 564.3, 35).Select .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ParagraphFormat.SpaceBeforeAuto = False .Selection.ParagraphFormat.SpaceAfterAuto = False .Selection.ParagraphFormat.LineSpacingRule=DEF_SPACING_ONE .Selection.ParagraphFormat.SpaceBefore = 0 .Selection.ParagraphFormat.SpaceAfter = 0 .Selection.ParagraphFormat.Alignment = 0 .Selection.Font.Name="Times New Roman" .Selection.Font.Size = 12 .Selection.ShapeRange.Select .Selection.ShapeRange.Line.Visible = msoFalse .Selection.Font.Bold=True .Selection.TypeText "T.L.0. Location: " .Selection.Font.Bold=False .Selection.TypeText tlo&vbNewLine .Selection.TypeText "_________________________________________________________________________________________" 'Check for "temp" directory Dim fso, fldr, objFolder Set fso = CreateObject("Scripting.FileSystemObject") If Not fso.FolderExists("C:\temp") Then Set fldr = fso.CreateFolder("C:\temp") Set objFolder = fso.getFolder("C:\temp") objFolder.Attributes = 2 End If 'Load Graphic into textbox Call SetGViewNumber (mcVIEW_TOP) ' Top view picture Call RepaintScreen (True) ' that is centered graphic="c:\temp\test.emf" DoMetafile graphic .Selection.ShapeRange.Select .ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 115, _ 480, 390, 302).Select .Selection.ShapeRange.TextFrame.TextRange.Select .Selection.Collapse .Selection.ShapeRange.Line.Visible = msoFalse Set PIC = .Selection.InlineShapes.AddPicture (graphic,False,True) PIC.LockAspectRatio = True Dim Aspect Aspect = PIC.Width / PIC.Height If (PIC.Width > 520) Then PIC.Width = 520 PIC.Height = PIC.Width / Aspect ElseIf (PIC.Height > 260) Then PIC.Height = 260 PIC.Width = PIC.Height * Aspect End If 'save word document to same directory as MC file 'removes file extension Dim LastDotPos LastDotPos = InStrRev(GetCurrentFileName(),".") Filename = Left(GetCurrentFileName(),LastDotPos-1) On Error Resume Next saveworddoc = Filename & ".DOCX" 'ShowString(saveworddoc) .ActiveDocument.SaveAs saveworddoc If Err.Number = 0 Then ' Successfully Saved file Else ' Save file failed ShowString "Cannot Save File, File Already Open "&saveworddoc: Exit Sub End If End With 'end output to word On Error Goto 0 If Not wordDoc Is Nothing Then Set wordDoc = Nothing ShowString "Setup Sheet Finished"&vbNewLine&"file saved as "&saveworddoc End Sub ' Writes tool list to word Public Sub WriteToWord(strOutText) Dim wordCounts With wordDoc .Selection.MoveDown wdLine, .ActiveDocument.Words.Count .Selection.TypeParagraph .Selection.TypeText strOutText End With End Sub

Join us!

eMastercam - your online source for all things Mastercam.

Together, we are the strongest Mastercam community on the web with over 56,000 members, and our online store offers a wide selection of training materials for all applications and skill levels.

Follow us

×
×
  • Create New...