PC-Dmis to Excel, through PC-Dmis Script

I know there is currently a VB project that runs in Excel during execution that will pull information into the workbook during execution. I decided to venture out and try some of my own approaches with a combination of data I found online here and there.

What I have is a script that can be executed in program, without too much setup and hassle, that will export data into an excel workbook like a print command would. I feel this script offers a little more versatility.

I will not claim ownership of this program. I just tweaked it to fit my needs. So far I have it running, and it works quite well.

I will answer what questions I can, but for the most part I wanted to post it to have as a reference.

It's a long program........

Parents

Rploughe over 9 years ago

Sub Main 
'xl Declarations
Dim xlApp As Object
Dim xlWorkbooks As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim fncSheet As Object
Dim count As Integer
Dim xlWorksheets As String 
Dim xlWorksheet As String 
'pcdlrn declarations And Open ppg
Dim App As Object
Set App = CreateObject("PCDLRN.Application")
Dim Part As Object
Set Part = App.ActivePartProgram
Dim Cmds As Object
Set Cmds = Part.Commands
Dim Cmd As Object
Dim DCmd As Object
Dim DcmdID As Object
Dim fs As Object 
Dim DimID As String 
Dim ReportDim As String
Dim CheckDim As String 
Dim Cavity As String  
Dim myValue As String 
Dim message, title, defaultValue As String
Dim FolderList$ ( )  
Set Project = Part.GetVariableValue("PROJECT")
myValue = Project.StringValue
If myValue = "" Then 
  myValue = InputBox("Please Input Project #","Project # Input","XXXXXX")
    For Each Cmd In Cmds
      If Cmd.Type = ASSIGNMENT Then
        If Cmd.GetText(DEST_EXPR,0) = "PROJECT" Then
      bln = Cmd.PutText("""" + myValue + """", SRC_EXPR, 0)
        Cmd.ReDraw
        End If
      End If
    Next Cmd
End If
    Dim objFSO, objFolder, objShell, firstchar, InputFolder, found, objDLG
myProject = "Project # " & myValue
    Dim serverpath
'Hardcoded absolute 
    serverpath = "X:\" 'Path coded As a network directory In "My Computer" To point To projects folder
    'Assign searchpath using "serverpath"
    Dim foldername As String
    Dim strDirectory
    Dim strDirectory1
    Dim strDirectory2
    Dim strDirectory3
    Dim strDirectory4
    Dim strDirectory5
    foldername = Dir(serverpath & "*.*", 16) 'value of "16" pulls In all folders In directory given
count = 0
While foldername <> ""
count = count +1
checker = Left(foldername,6)
        If checker = myValue Then
            strDirectory = serverpath & foldername
            strDirectory1 = strDirectory & "\Non-Disclosure Agreement"
        End If
foldername = Dir ' find the Next file
    Wend 
'Create filesystemobject
Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Check If the folder "Non-Disclosure Agreement" exists
    If objFSO.FolderExists(strDirectory1) Then
        objFolder = objFSO.GetFolder(strDirectory1)
        found = 1
    Else
        strDirectory = strDirectory & "\"
        found = 0
    End If
    Dim CMDline, CMDvar, CMDval, Delimpos, CMDfind
    'Handle For "Non-Disclosure Agreement" Not existing
    If (found = 0) Then
        foldername = Dir(strDirectory & "*.*", 16) 'value of "16" pulls In all folders In directory given
        count = 0
        While foldername <> ""
            count = count + 1
            delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
            If delimpos Then
                CMDval = Right(foldername, 4)
                If CMDval = "Engineering" Then
                    strDirectory1 = strDirectory & foldername
                End If
            End If
            foldername = Dir ' find the Next file
        Wend 
    End If
    'Find "Engineering Folder"
    strDirectory1 = strDirectory1 & "\"
        foldername = Dir(strDirectory1 & "*.*", 16) 'value of "16" pulls In all folders In directory given
        count = 0
        While foldername <> ""
            count = count + 1
            delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
            If delimpos Then
                CMDval = Right(foldername,len(foldername) - delimpos)
                If CMDval = "Engineering" Then
                strDirectory2 = strDirectory1 & foldername
                strDirectory3 = strDirectory2 & "\09 Inspection"
                End If
            End If
            foldername = Dir ' find the Next file
       Wend 
    'Check If the folder "09 Inspection" exists
    If objFSO.FolderExists(strDirectory3) Then
        objFolder = objFSO.GetFolder(strDirectory3)
        found = 1
    Else
        strDirectory2 = strDirectory2 & "\"
        found = 0
    End If
    'Handle For "09 Inspection" Not existing
    If (found = 0) Then
        foldername = Dir(strDirectory2 & "*.*", 16) 'value of "16" pulls In all folders In directory given
        count = 0
        While foldername <> ""
            count = count + 1
            delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
            If delimpos Then
                CMDval = Right(foldername,len(foldername) - delimpos)
                If CMDval = "Inspection" Then
                    strDirectory3 = strDirectory2 & foldername
                End If
            End If
            foldername = Dir ' find the Next file
        Wend 
    End If
    'Find "CMM Data" Folder
    strDirectory3 = strDirectory3 & "\"
    foldername = Dir(strDirectory3 & "*.*", 16) 'value of "16" pulls In all folders In directory given
    count = 0
    founder = 0
    While foldername <> ""
        count = count + 1
        delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
        If delimpos Then
            CMDval = Right(foldername,len(foldername) - delimpos)
            If CMDval = "CMM Programs & Documentation" Then
                founder = 1
                strDirectory4 = strDirectory3 & foldername
                strDirectory5 = strDirectory4
            End If
        End If
        foldername = Dir ' find the Next file
    Wend 
    If (founder = 0) Then
        'Check If the folder "02 CMM Programs & Documentation" exists
        If objFSO.FolderExists(strDirectory5) Then
            objFolder = objFSO.GetFolder(strDirectory5)
        'Else
            objFolder = objFSO.CreateFolder(strDirectory5)
            objFolder = objFSO.GetFolder(strDirectory5)
        End If
    End If
    'If the folder existed
        'Check To see If results file exists
        FilePath = strDirectory5 & "\"
        Set prognam = Part.GetVariableValue("CMMPROGRAM")
        ResFileExists = FilePath & Prognam.StringValue & ".xlsx"
Dim TempFilename
        If objFSO.FileExists(ResFileExists) = False Then
            TempFilename = "X:\00 Sub Folders\13 Engineering\09 Inspection\02 CMM Programs & Documentation\" & "Program Template.xlsx"
        Else
            TempFilename = FilePath & Prognam.StringValue & ".xlsx"
        End If
        On Error GoTo ErrorCheck

Reply

Rploughe over 9 years ago

Sub Main 
'xl Declarations
Dim xlApp As Object
Dim xlWorkbooks As Object
Dim xlWorkbook As Object
Dim xlSheet As Object
Dim fncSheet As Object
Dim count As Integer
Dim xlWorksheets As String 
Dim xlWorksheet As String 
'pcdlrn declarations And Open ppg
Dim App As Object
Set App = CreateObject("PCDLRN.Application")
Dim Part As Object
Set Part = App.ActivePartProgram
Dim Cmds As Object
Set Cmds = Part.Commands
Dim Cmd As Object
Dim DCmd As Object
Dim DcmdID As Object
Dim fs As Object 
Dim DimID As String 
Dim ReportDim As String
Dim CheckDim As String 
Dim Cavity As String  
Dim myValue As String 
Dim message, title, defaultValue As String
Dim FolderList$ ( )  
Set Project = Part.GetVariableValue("PROJECT")
myValue = Project.StringValue
If myValue = "" Then 
  myValue = InputBox("Please Input Project #","Project # Input","XXXXXX")
    For Each Cmd In Cmds
      If Cmd.Type = ASSIGNMENT Then
        If Cmd.GetText(DEST_EXPR,0) = "PROJECT" Then
      bln = Cmd.PutText("""" + myValue + """", SRC_EXPR, 0)
        Cmd.ReDraw
        End If
      End If
    Next Cmd
End If
    Dim objFSO, objFolder, objShell, firstchar, InputFolder, found, objDLG
myProject = "Project # " & myValue
    Dim serverpath
'Hardcoded absolute 
    serverpath = "X:\" 'Path coded As a network directory In "My Computer" To point To projects folder
    'Assign searchpath using "serverpath"
    Dim foldername As String
    Dim strDirectory
    Dim strDirectory1
    Dim strDirectory2
    Dim strDirectory3
    Dim strDirectory4
    Dim strDirectory5
    foldername = Dir(serverpath & "*.*", 16) 'value of "16" pulls In all folders In directory given
count = 0
While foldername <> ""
count = count +1
checker = Left(foldername,6)
        If checker = myValue Then
            strDirectory = serverpath & foldername
            strDirectory1 = strDirectory & "\Non-Disclosure Agreement"
        End If
foldername = Dir ' find the Next file
    Wend 
'Create filesystemobject
Set objFSO = CreateObject("Scripting.FileSystemObject")
    'Check If the folder "Non-Disclosure Agreement" exists
    If objFSO.FolderExists(strDirectory1) Then
        objFolder = objFSO.GetFolder(strDirectory1)
        found = 1
    Else
        strDirectory = strDirectory & "\"
        found = 0
    End If
    Dim CMDline, CMDvar, CMDval, Delimpos, CMDfind
    'Handle For "Non-Disclosure Agreement" Not existing
    If (found = 0) Then
        foldername = Dir(strDirectory & "*.*", 16) 'value of "16" pulls In all folders In directory given
        count = 0
        While foldername <> ""
            count = count + 1
            delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
            If delimpos Then
                CMDval = Right(foldername, 4)
                If CMDval = "Engineering" Then
                    strDirectory1 = strDirectory & foldername
                End If
            End If
            foldername = Dir ' find the Next file
        Wend 
    End If
    'Find "Engineering Folder"
    strDirectory1 = strDirectory1 & "\"
        foldername = Dir(strDirectory1 & "*.*", 16) 'value of "16" pulls In all folders In directory given
        count = 0
        While foldername <> ""
            count = count + 1
            delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
            If delimpos Then
                CMDval = Right(foldername,len(foldername) - delimpos)
                If CMDval = "Engineering" Then
                strDirectory2 = strDirectory1 & foldername
                strDirectory3 = strDirectory2 & "\09 Inspection"
                End If
            End If
            foldername = Dir ' find the Next file
       Wend 
    'Check If the folder "09 Inspection" exists
    If objFSO.FolderExists(strDirectory3) Then
        objFolder = objFSO.GetFolder(strDirectory3)
        found = 1
    Else
        strDirectory2 = strDirectory2 & "\"
        found = 0
    End If
    'Handle For "09 Inspection" Not existing
    If (found = 0) Then
        foldername = Dir(strDirectory2 & "*.*", 16) 'value of "16" pulls In all folders In directory given
        count = 0
        While foldername <> ""
            count = count + 1
            delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
            If delimpos Then
                CMDval = Right(foldername,len(foldername) - delimpos)
                If CMDval = "Inspection" Then
                    strDirectory3 = strDirectory2 & foldername
                End If
            End If
            foldername = Dir ' find the Next file
        Wend 
    End If
    'Find "CMM Data" Folder
    strDirectory3 = strDirectory3 & "\"
    foldername = Dir(strDirectory3 & "*.*", 16) 'value of "16" pulls In all folders In directory given
    count = 0
    founder = 0
    While foldername <> ""
        count = count + 1
        delimpos = instr(1, foldername, " ") 'Find the delimeter (space), "13 Eng" ex.
        If delimpos Then
            CMDval = Right(foldername,len(foldername) - delimpos)
            If CMDval = "CMM Programs & Documentation" Then
                founder = 1
                strDirectory4 = strDirectory3 & foldername
                strDirectory5 = strDirectory4
            End If
        End If
        foldername = Dir ' find the Next file
    Wend 
    If (founder = 0) Then
        'Check If the folder "02 CMM Programs & Documentation" exists
        If objFSO.FolderExists(strDirectory5) Then
            objFolder = objFSO.GetFolder(strDirectory5)
        'Else
            objFolder = objFSO.CreateFolder(strDirectory5)
            objFolder = objFSO.GetFolder(strDirectory5)
        End If
    End If
    'If the folder existed
        'Check To see If results file exists
        FilePath = strDirectory5 & "\"
        Set prognam = Part.GetVariableValue("CMMPROGRAM")
        ResFileExists = FilePath & Prognam.StringValue & ".xlsx"
Dim TempFilename
        If objFSO.FileExists(ResFileExists) = False Then
            TempFilename = "X:\00 Sub Folders\13 Engineering\09 Inspection\02 CMM Programs & Documentation\" & "Program Template.xlsx"
        Else
            TempFilename = FilePath & Prognam.StringValue & ".xlsx"
        End If
        On Error GoTo ErrorCheck

Children

No Data