Worksheet opslaan als

[Delfi]

Hallo allemaal,

Ik heb een stuk code op het internet gevonden om de worksheet op te slaan als .txt. Ik heb nog het een en ander aangepast/toegevoegd om het werkend te krijgen. Opzich werkt dit prima, alleen nou moet ik eerst een .txt bestand aangemaakt hebben in die map anders krijg ik een foutmelding. Wat ik eigenlijk wil is dat zodra ik op de knop 'opslaan' klik ik mag kiezenhoe ik het bestand wil noemen en waar ik het wil opslaan. Dus een opslaan als dialog window, nou heb ik al zoiets op het internet gevonden alleen weet ik niet hoe ik het moet combineren met deze code. Kan iemand mij in de juiste richting sturen?

Hieronder mijn code.

Sub Kopieren(wks As Worksheet)

  Const ForAppending As Long = 8
  Const AsciiFormat As Long = 0
 
  Dim C As Long
  Dim ColArray() As Long
  Dim BlankCols As Range
  Dim n As Long
  Dim r As Long
  Dim rng As Range

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TxtFile = FSO.OpenTextFile("C:\Users\scada\Desktop\Test\Motor.txt" _
    , ForAppending, DefaultFormat)

    With wks.UsedRange
      StartRow = .Row
      LastRow = .Rows.Count + StartRow - 1
      StartCol = .Column
      LastCol = .Columns.Count + StartCol - 1
      On Error Resume Next
        Set BlankCols = .SpecialCells(xlCellTypeBlanks)
          If Err.Number = 1004 Then
             Err.Clear
             GoTo NoMoreBlanks
          End If
      On Error GoTo 0
    End With
    
      For Each rng In BlankCols.Areas
        ReDim Preserve ColArray(n)
          ColArray(n) = rng.Column
        n = n + 1
      Next rng
        
        For n = 0 To UBound(ColArray)
          StopCol = ColArray(n) - 1
          Set rng = wks.Range(Cells(StartRow, StartCol), Cells(LastRow, StopCol))
             GoSub WriteDataToFile
          StartCol = ColArray(n) + 1
         Next n
         
NoMoreBlanks:
         If Err.Number <> 0 Then GoTo Finished
         Set rng = wks.Range(Cells(StartRow, StartCol), Cells(LastRow, LastCol))
         GoSub WriteDataToFile
         GoTo Finished
         
WriteDataToFile:
        For r = 1 To rng.Rows.Count
          For C = 1 To rng.Columns.Count
            TxtData = TxtData & rng.Cells(r, C) & vbTab
          Next C
          TxtData = Left(TxtData, Len(TxtData) - 1)
          If TxtData = "" Then GoTo Volgende
            TxtFile.Writeline (TxtData & "-aan")
            TxtFile.Writeline (TxtData & "-uit")
            TxtFile.Writeline (TxtData & "-vrij")
            TxtFile.Writeline (TxtData & "-TMO")
            TxtFile.Writeline (TxtData & "-TMI")
            TxtFile.Writeline vbClrf
          TxtData = ""
Volgende:
        Next r
    Return
      
Finished:
  Set MSO = Nothing
  Set TxtFile = Nothing
  
End Sub

Sub Opslaan()

  Dim wks As Worksheet
    
   Application.ScreenUpdating = False
   
      For Each wks In ThisWorkbook.Worksheets
        wks.Activate
        Kopieren wks
      Next wks
    
   Application.ScreenUpdating = True
    
End Sub

Groeten,

Delfi