Help with 2 Scripts

Hi guys

I'm trying to get 2 scripts to work which I took from this forum and tried to adjust to our company needs as well as unify the code (using the same commands & variables)
I don't know how to script I just tried to understand from the description in the threads and in the scripts.

The first one is the folder create script:
https://www.pcdmisforum.com/forum/pc-dmis-enterprise-metrology-software/pc-dmis-code-samples/8758-create-folder-script

Sub main()


'************************************************* ************************************************** **********************
' Basierend auf dem "Create folder" Script von vpt.se und chadjac
' Based On the "Create folder" script from vpt.se und chadjac
' https://www.pcdmisforum.com/forum/pc-dmis-enterprise-metrology-software/pc-dmis-code-samples/8758-create-folder-script
'************************************************* ************************************************** **********************


'-------------------------------------------------------------------------------------------------------------------------
' Erstellt die Objekte
' Create the objects
'-------------------------------------------------------------------------------------------------------------------------
Dim pcdapp As Object
Set pcdapp = createobject("pcdlrn.application")

Dim pcdpartprogram As Object
Set pcdpartprogram = pcdapp.activepartprogram

Dim fso As Object
Set fso = createobject("scripting.filesystemobject")


'-------------------------------------------------------------------------------------------------------------------------
' Findet die PC-DMIS Variable für den Protokoll Speicherpfad
' Gets the PC-DMIS variable For the protocol path
'-------------------------------------------------------------------------------------------------------------------------
Dim pathname As Object
Set pathname=pcdpartprogram.getvariablevalue("V_PROTOK OLL_PFAD")

strpath=pathname.stringvalue


'-------------------------------------------------------------------------------------------------------------------------
' Prüft ob der Protokoll Speicherpfad existiert & erstellt ihn wenn nicht
' Checks If the protocol path exists And creates it If Not
'-------------------------------------------------------------------------------------------------------------------------
Dim fsofolder As Object

If Not fso.folderexists(strpath) Then
Set fsofolder = fso.createfolder(strpath)
End If



'-------------------------------------------------------------------------------------------------------------------------
' Räumt auf
' Tidies up
'-------------------------------------------------------------------------------------------------------------------------
Set fso = Nothing
Set pcdpartprogram = Nothing
Set pcdapp = Nothing


End Sub

and the second is the AutoArchive script:
https://www.pcdmisforum.com/forum/pc-dmis-enterprise-metrology-software/pc-dmis-code-samples/390021-auto-archive-freebie

Sub main()


'************************************************* ************************************************** **********************
' Basierend auf dem "AUTOARCHIVE.BAS" Script von NinjaBadger (JON WOOD)
' Based On the "AUTOARCHIVE.BAS" script from NinjaBadger (JON WOOD)
' https://www.pcdmisforum.com/forum/pc-dmis-enterprise-metrology-software/pc-dmis-code-samples/390021-auto-archive-freebie
'************************************************* ************************************************** **********************


'-------------------------------------------------------------------------------------------------------------------------
' Erstellt die Objekte
' Create the objects
'-------------------------------------------------------------------------------------------------------------------------
Dim pcdapp As Object
Set pcdapp = createobject("pcdlrn.application")

Dim pcdpartprogram As Object
Set pcdpartprogram = pcdapp.activepartprogram

Dim fso As Object
Set fso = createobject("scripting.filesystemobject")


'-------------------------------------------------------------------------------------------------------------------------
' Speichert das originale Messprogramm
' Saves the original part program
'-------------------------------------------------------------------------------------------------------------------------
pcdpartprogram.save


'-------------------------------------------------------------------------------------------------------------------------
' Findet den vollen Namen des originalen Messprogramms (mit Pfad & Dateiendung)
' Gets the full Name of the original part program (With path & file extension)
'-------------------------------------------------------------------------------------------------------------------------
Dim source_path
source_path = pcdpartprogram.fullname


'-------------------------------------------------------------------------------------------------------------------------
' Findet die PC-DMIS Variablen für den Archiv Speicherpfad und Dateinamen
' Gets the PC-DMIS variables For the archive path And file Name
'-------------------------------------------------------------------------------------------------------------------------
Dim pathname As Object
Set pathname=pcdpartprogram.getvariablevalue("V_ARCHIV _PFAD")

strpath=pathname.stringvalue


Dim partname As Object
Set partname=pcdpartprogram.getvariablevalue("V_ARCHIV _NAME")

strpart=partname.stringvalue


'-------------------------------------------------------------------------------------------------------------------------
' Prüft ob der Archiv Speicherpfad existiert & erstellt ihn wenn nicht
' Checks If the archive path exists And creates it If Not
'-------------------------------------------------------------------------------------------------------------------------
Dim fsofolder As Object

If Not fso.folderexists(strpath) Then
Set fsofolder = fso.createfolder(strpath)
End If


'-------------------------------------------------------------------------------------------------------------------------
' Generiert den vollen Archiv Namen (mit Pfad & Dateiendung)
' Generates the full archive Name (With path & file extension)
'-------------------------------------------------------------------------------------------------------------------------
dest_path = strpath & "\" & strpart & "_" & format(now(),"YYYYMMDDHHNNSS") & ".prg"
'MsgBox(dest_path)


'-------------------------------------------------------------------------------------------------------------------------
' Kopiert die Originaldatei In das Archiv
' Copies the original file To the archive
'-------------------------------------------------------------------------------------------------------------------------
fso.copyfile source_path, dest_path


'-------------------------------------------------------------------------------------------------------------------------
' Räumt auf
' Tidies up
'-------------------------------------------------------------------------------------------------------------------------
Set fso = Nothing
Set pcdpartprogram = Nothing
Set pcdapp = Nothing


End Sub

This is the Code in PC-DMIS:

On both the scripts I get the error (OLE Automation method exception) on the same command: Set fsofolder = fso.createfolder(strpath)

Do you guys see the error I made?

Thanks in advance for your help.

Attached Files

Parents

Henniger123 over 3 years ago

ah now i get it,

"fso.createfolder(strpath)" failed if you try to create multible folders at once.
It can only create the last folder in the path and only if the rest of the path exists

if this is the problem, you will need something like this:

Sub pcDMIS_ForceDirectories(ByVal sPath As String)
  Dim vPath, sPuffer As String
  vPath = Trim(sPath)

  If Right(vPath, 1) = "\" Then
    vPath = Mid(vPath, 1, Len(vPath) - 1)
  End If

  Dim N1 As Integer
  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  Dim fsofolder As Object

  N1 = InStr(4, vPath, "\")
  If (N1 <> 0) and (Not fso.folderexists(vPath)) Then
    sPuffer = Mid(vPath, 1, N1 - 1)
    Do While N1 <> 0
      If Not fso.folderexists(sPuffer) Then
        Set fsofolder = fso.createfolder(sPuffer)
      End If

      N1 = InStr(N1 + 1, vPath, "\")
      If N1 <> 0 Then sPuffer = Mid(vPath, 1, N1 - 1)
    Loop
  end if


  If Not fso.folderexists(vPath) Then
    Set fsofolder = fso.createfolder(vPath)
  End If

  Set fso = Nothing
End Sub

grüße

Reply

Henniger123 over 3 years ago

ah now i get it,

"fso.createfolder(strpath)" failed if you try to create multible folders at once.
It can only create the last folder in the path and only if the rest of the path exists

if this is the problem, you will need something like this:

Sub pcDMIS_ForceDirectories(ByVal sPath As String)
  Dim vPath, sPuffer As String
  vPath = Trim(sPath)

  If Right(vPath, 1) = "\" Then
    vPath = Mid(vPath, 1, Len(vPath) - 1)
  End If

  Dim N1 As Integer
  Dim fso As Object
  Set fso = CreateObject("Scripting.FileSystemObject")
  Dim fsofolder As Object

  N1 = InStr(4, vPath, "\")
  If (N1 <> 0) and (Not fso.folderexists(vPath)) Then
    sPuffer = Mid(vPath, 1, N1 - 1)
    Do While N1 <> 0
      If Not fso.folderexists(sPuffer) Then
        Set fsofolder = fso.createfolder(sPuffer)
      End If

      N1 = InStr(N1 + 1, vPath, "\")
      If N1 <> 0 Then sPuffer = Mid(vPath, 1, N1 - 1)
    Loop
  end if


  If Not fso.folderexists(vPath) Then
    Set fsofolder = fso.createfolder(vPath)
  End If

  Set fso = Nothing
End Sub

grüße

Children

No Data