I want to develop a print system for check a daily list of documents to print and do it every hour.
Until now I could print one document but when the time has come to print more the code only works for the first.
Sub printTag()
Dim strCommand As String
Dim filePath As String
Dim FileName As String
Dim printer As String
Dim numRefs As Integer
Dim x As Integer
Dim ref As String
Dim numFiles As Integer
Dim t As Integer
Dim difD As Long
Dim difH As Long
Dim difM As Long
Dim listDate As Date
Dim nowDate As Date
nowDate = ThisWorkbook.Sheets("Print").Range("B8")
printer = ThisWorkbook.Sheets("Print").Range("B2")
numRefs = WorksheetFunction.CountA(ThisWorkbook.Sheets("List").Columns("A"))
numFiles = WorksheetFunction.CountA(ThisWorkbook.Sheets("Relation").Columns("A"))
For x = 1 To numRefs
On Error Resume Next
listDate = ThisWorkbook.Sheets("List").Range("A" & x)
difD = DateDiff("d", nowDate, listDate)
If difD = 0 Then
difH = DateDiff("h", nowDate, listDate)
difM = DateDiff("n", nowDate, listDate)
If difH = 0 Then
If difM >= 0 Then
For t = 1 To numFiles
If ThisWorkbook.Sheets("List").Range("B" & x) = ThisWorkbook.Sheets("Relation").Range("A" & t) Then
filePath = ThisWorkbook.Sheets("Print").Range("B1") & "\" & ThisWorkbook.Sheets("Relation").Range("B" & t)
ThisWorkbook.Sheets("Print").Range("B3") = strCommand
strCommand = "PRINT " & filePath & "/D:" & printer
Shell strCommand, 1
End If
Next t
End If
End If
End If
Next x
End Sub
I'd got the idea to create a script instead send multiples instances in command line and works perfectly. This is the result:
Sub printTag()
Dim strCommand As String
Dim filePath As String
Dim FileName As String
Dim printer As String
Dim numRefs As Integer
Dim x As Integer
Dim ref As String
Dim numFiles As Integer
Dim t As Integer
Dim difD As Long
Dim difH As Long
Dim difM As Long
Dim listDate As Date
Dim nowDate As Date
nowDate = ThisWorkbook.Sheets("Print").Range("B8")
printer = ThisWorkbook.Sheets("Print").Range("B2")
numRefs = WorksheetFunction.CountA(ThisWorkbook.Sheets("List").Columns("A"))
numFiles = WorksheetFunction.CountA(ThisWorkbook.Sheets("Relation").Columns("A"))
If Len(Dir$(ThisWorkbook.Path & "\list.bat")) > 0 Then
Kill ThisWorkbook.Path & "\list.bat"
End If
intFile = FreeFile()
Open ThisWorkbook.Path & "\list.bat" For Output As #intFile
For x = 1 To numRefs
On Error Resume Next
listDate = ThisWorkbook.Sheets("List").Range("A" & x)
difD = DateDiff("d", nowDate, listDate)
If difD = 0 Then
difH = DateDiff("h", nowDate, listDate)
difM = DateDiff("n", nowDate, listDate)
If difH = 0 Then
If difM >= 0 Then
For t = 1 To numFiles
If ThisWorkbook.Sheets("List").Range("B" & x) = ThisWorkbook.Sheets("Relation").Range("A" & t) Then
filePath = ThisWorkbook.Sheets("Print").Range("B1") & "\" & ThisWorkbook.Sheets("Relation").Range("B" & t)
Print #intFile, "PRINT " & filePath & " /D:" & printer
End If
Next t
End If
End If
End If
Next x
Print #intFile, "exit"
Close #intFile
End Sub
Related
In MS Access, I want to rename filename of the attachment with ID and filename so that there should be any problem for duplicates. For example, if the id is 1 and filename is ABC then name in the folder should be 1ABC or 1_ABC anything is fine. Currently it is saving as ABC.extension (pdf/docx/txt).
Try this.
Private Sub Command0_Click()
Dim counter As Long
counter = SaveAttachments("D:\Test1")
MsgBox counter & " files exported."
End Sub
Public Function SaveAttachments(savePath As String, Optional strPattern As String = "*.*") As Long
Dim r As DAO.Recordset
Dim r2 As DAO.Recordset2
Dim strFullPath As String
Dim counter As Long
Set r = CurrentDb().OpenRecordset("Notices")
Do While Not r.EOF
Set r2 = r("Attachments").Value
Do While Not r2.EOF
If r2("FileName") Like strPattern Then
strFullPath = savePath & "\" & r("ID") & "_" & r2("FileName")
If Dir(strFullPath) = "" Then
r2("FileData").SaveToFile strFullPath
counter = counter + 1
End If
End If
r2.MoveNext
Loop
If Not r2 Is Nothing Then r2.Close
r.MoveNext
Loop
If Not r Is Nothing Then r.Close
SaveAttachments = counter
End Function
I want to give credit to an agent, if they're the one that sent the message, but only if their signature is at the top of the email.
Here is what I have. The search order is off. The code searches for one name at a time, and clear through the document. I need it to search for All names, the first one that hits in the body of the email.
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim strSpecificText As String
Dim tmpStr As String
Dim x As Integer
Dim Count As Integer
Dim HunterCnt As Integer
Dim SunmolaCnt As Integer
Dim RodriguezCnt As Integer
Dim MammedatyCnt As Integer
Dim MitchellCnt As Integer
Dim TannerCnt As Integer
Dim TAYLORCnt As Integer
Dim WilsonCnt As Integer
Dim WilliamsCnt As Integer
Dim GrooverCnt As Integer
Dim TyreeCnt As Integer
Dim ChapmanCnt As Integer
Dim LukerCnt As Integer
Dim KlinedinstCnt As Integer
Dim HicksCnt As Integer
Dim NATHANIALCnt As Integer
Dim SkinnerCnt As Integer
Dim SimonsCnt As Integer
Dim AgentNames(14) As Variant
AgentNames(0) = "Simons"
AgentNames(1) = "Skinner"
AgentNames(2) = "Mammedaty"
AgentNames(3) = "Hunter"
AgentNames(4) = "Sunmola"
AgentNames(5) = "Rodriguez"
AgentNames(6) = "Mitchell"
AgentNames(7) = "Tanner"
AgentNames(8) = "Taylor"
AgentNames(9) = "Wilson"
AgentNames(10) = "Williams"
AgentNames(11) = "Groover"
AgentNames(12) = "Tyree"
AgentNames(13) = "Chapman"
AgentNames(14) = "Luker"
x = 0
While x < ActiveExplorer.Selection.Count
x = x + 1
Set MailItem = ActiveExplorer.Selection.item(x)
tmpStr = MailItem.Body
For Each Agent In AgentNames
If InStr(tmpStr, Agent) <> 0 Then
If Agent = "Assunta" Then
HunterCnt = HunterCnt + 1
GoTo skip
End If
If Agent = "Sunmola" Then
SunmolaCnt = SunmolaCnt + 1
GoTo skip
End If
If Agent = "Rodriguez" Then
RodriguezCnt = RodriguezCnt + 1
GoTo skip
End If
If Agent = "Mammedaty" Then
MammedatyCnt = MammedatyCnt + 1
GoTo skip
End If
If Agent = "Mitchell" Then
MitchellCnt = MitchellCnt + 1
GoTo skip
End If
If Agent = "Tanner" Then
TannerCnt = TannerCnt + 1
GoTo skip
End If
If Agent = "Taylor" Then
TAYLORCnt = TAYLORCnt + 1
GoTo skip
End If
If Agent = "Wilson" Then
WilsonCnt = WilsonCnt + 1
GoTo skip
End If
If Agent = "Williams" Then
WilliamsCnt = WilliamsCnt + 1
GoTo skip
End If
If Agent = "Groover" Then
GrooverCnt = GrooverCnt + 1
GoTo skip
End If
If Agent = "Tyree" Then
TyreeCnt = TyreeCnt + 1
GoTo skip
End If
If Agent = "Chapman" Then
ChapmanCnt = ChapmanCnt + 1
GoTo skip
End If
If Agent = "Luker" Then
LukerCnt = LukerCnt + 1
GoTo skip
End If
If Agent = "Hicks" Then
HicksCnt = HicksCnt + 1
GoTo skip
End If
End If
Next
skip:
Count = Count + 1
Wend
MsgBox "Found " & vbCrLf & "Hunter Count: " & HunterCnt & vbCrLf & "Sunmola Count: " & SunmolaCnt & vbCrLf & "Rodriguez Count: " & RodriguezCnt & vbCrLf & "Mammedaty Count: " & MammedatyCnt & vbCrLf & "Mitchell Count: " & MitchellCnt & vbCrLf & "Tanner Count: " & TannerCnt & vbCrLf & "Taylor Count: " & TAYLORCnt & vbCrLf & "Wilson Count: " & WilsonCnt & vbCrLf & "Williams Count: " & WilliamsCnt & vbCrLf & "Groover Count: " & GrooverCnt & vbCrLf & "Tyree Count: " & TyreeCnt & vbCrLf & "Chapman Count: " & ChapmanCnt & vbCrLf & "Luker Count: " & LukerCnt & vbCrLf & " in: " & Count & " emails"
End Sub
InStr returns positional information. While it is difficult to find the first occurrence of an array member within the text (you would need to build and compare matches), you can find the first position of each name then find which came first.
For example (untested)
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim i As Long, x As Long, position As Long, First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
Dim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For i = LBound(AgentCount) To UBound(AgentCount)
AgentCount(i) = 0
Next i
For Each MailItem In ActiveExplorer.Selection
x = 0
For i = LBound(AgentNames) To UBound(AgentNames)
position = InStr(MailItem.Body, AgentNames(i))
If x > 0 Then
If position < x Then
x = position
First = i
End If
Else
If position > 0 Then
x = position
First = i
End If
End If
Next i
AgentCount(First) = AgentCount(First) + 1
Next MailItem
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
The idea in the previous answer may be better implemented like this:
Option Explicit
Sub CountOccurences_SpecificText_SelectedItems()
Dim objItem As Object
Dim objMail As MailItem
Dim i As Long
Dim j As Long
Dim x As Long
Dim position As Long
Dim First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
ReDim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For j = 1 To ActiveExplorer.Selection.Count
Set objItem = ActiveExplorer.Selection(j)
' Verify before attempting to return mailitem poroperties
If TypeOf objItem Is MailItem Then
Set objMail = objItem
Debug.Print
Debug.Print "objMail.Subject: " & objMail.Subject
x = Len(objMail.Body)
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print
Debug.Print "AgentNames(i): " & AgentNames(i)
position = InStr(objMail.Body, AgentNames(i))
Debug.Print " position: " & position
If position > 0 Then
If position < x Then
x = position
First = i
End If
End If
Debug.Print "Lowest position: " & x
Debug.Print " Current first: " & AgentNames(First)
Next i
If x < Len(objMail.Body) Then
AgentCount(First) = AgentCount(First) + 1
Debug.Print
Debug.Print AgentNames(First) & " was found first"
Else
Debug.Print "No agent found."
End If
End If
Next
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
I have a userform with a list of selections for three headings in a table. Each heading will have at least one selection. I'm trying to separate each selection with a comma and end the list with a period.
The table is populated on button click.
Private Sub CommandButton6_Click()
Dim tableSequence As Table
Set tableSequence = ActiveDocument.Tables(1)
Dim NewRow As Row
Set NewRow = tableSequence.Rows.Add
Dim MyString2 As String
Dim MyString5 As String
Dim v As Variant
Dim t As String
Dim r As String
Dim i As Long
Dim L As Long
Dim var
Dim var1
Dim MyString3 As String
Dim MyString4 As String
Dim var2
Dim var3
Dim p As String
Dim M As Long
Dim q As String
Dim Y As Long
For var3 = 0 To ListBox7.ListCount - 1
If ListBox7.Selected(var3) = True Then
MyString5 = MyString5 & ListBox7.List(var3)
v = Split(MyString5, ",")
p = ""
For M = LBound(v) To UBound(v)
p = p + v(M)
If M Mod 3 = 2 Then
p = p + vbCr
Else
p = p + ","
End If
Next M
p = Left(p, Len(p) - 1)
Debug.Print p
End If
Next
NewRow.Cells(2).Range.Text = TextBox8.Text
NewRow.Cells(3).Range.Text = TextBox9.Text
NewRow.Cells(4).Range.Text = MyString2
NewRow.Cells(5).Range.Text = "Engineering: " & MyString3 & "." _
& vbCrLf & "Administrative: " _
& MyString4 & "." & vbCrLf & "PPE: " & MyString5 & "."
NewRow.Cells(5).Range.Bold = False
NewRow.Cells(5).Range.Underline = False
NewRow.Cells(6).Range.Text = ComboBox1.Text
NewRow.Cells(7).Range.Text = ComboBox2.Text
NewRow.Cells(8).Range.Text = ComboBox3.Text
Dim keywordArr As Variant
keywordArr = Array("Engineering:", "Administrative:", "PPE:")
Dim keyword As Variant
Dim myRange As Variant
Dim startPos As Integer
Dim endPos As Integer
Dim length As Integer
Dim i1 As Integer
i1 = 1
For Each keyword In keywordArr
Do While InStr(1, myRange, keyword) = 0
Set myRange = NewRow.Cells(5).Range.Paragraphs(i1).Range
i1 = i1 + 1
Loop
startPos = InStr(1, myRange, keyword)
startPos = myRange.Characters(startPos).Start
length = Len(keyword)
endPos = startPos + length
Set myRange = ActiveDocument.Range(startPos, endPos)
With myRange.Font
.Bold = True
.Underline = True
End With
Next keyword
End Sub
I believe that the portion of code from For var3 to the second end if should provide my comma delimiter.
The attached image shows what I'm getting on the left vs. what I'm trying to get on the right.
You need to add the commas as you build the string.
For var3 = 0 To ListBox7.ListCount - 1
If ListBox7.Selected(var3) = True Then
If MyString5 = vbNullString Then
MyString5 = ListBox7.List(var3)
Else
MyString5 = MyString5 & ", " & ListBox7.List(var3)
End If
End If
Next
Is there a way to find the number of items in an array?
My list of txt files is:
C.txt
D.txt
G.txt
H.txt
With the code below I aggregated the txt files for have output only one txt file (output.txt).
But I need aggregate the files txt only when all four txt files are presents in the path of server else I need alert message in the code.
Can you help me?
Thank you in advance.
Option Compare Database
Dim path
Function go()
Dim ArrTest() As Variant
Dim I As Integer
Dim StrFileName As String
path = CurrentProject.Path
Ouput:
ArrTest = Array("C", "D", "G", "H")
file_global = "" & path & "\Output.txt"
fn = FreeFile
Open file_global For Output As fn
Close
For I = 0 To UBound(ArrTest)
StrFileName = "" & path & "\Output_" & ArrTest(I) & ".txt"
fn = FreeFile
Open StrFileName For Input As fn
Open file_global For Append As fn + 1
Line Input #fn, datum
Do While Not EOF(fn)
Line Input #fn, datum
datums = Split(datum, Chr(9))
For d = 0 To UBound(datums)
If d = 0 Then
datum = Trim(datums(d))
Else
datum = datum & ";" & Trim(datums(d))
End If
Next
Print #fn + 1, datum
Loop
Close
Next I
Application.Quit
End Function
Try this (different than your method, but tried and tested, Assuming All text files including calling workbook reside in same folder) :
Option Explicit
Private Sub AppendTxtfilesConditional()
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim path As String, xp, J As Integer, I As Integer, K As Integer
Dim FSOStream As Object, FSOStream1 As Object, FSO As Object, fol As Object, fil As Object
Dim srcFile As Object, desFile As Object
Dim ArrTest() As Variant
ArrTest = Array("C", "D", "G", "H")
J = 0
path = ThisWorkbook.path
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fol = FSO.GetFolder(path)
For I = 0 To UBound(ArrTest)
K = 0
For Each fil In fol.Files
If ArrTest(I) & ".txt" = fil.Name Then
MsgBox (ArrTest(I) & ".txt" & " is found")
J = J + 1
If J > UBound(ArrTest) Then GoTo L12
K = J
End If
Next
If K = 0 Then MsgBox ArrTest(I) & ".txt" & " not found"
Next
MsgBox "aborted"
GoTo final
L12:
For I = 0 To UBound(ArrTest)
Set srcFile = FSO.GetFile(path & "\" & ArrTest(I) & ".txt")
On Error GoTo erLabel
Set desFile = FSO.GetFile(path & "\Output.txt")
On Error GoTo 0
Set FSOStream = srcFile.OpenAsTextStream(iomode:=ForReading, Format:=TristateUseDefault)
Set FSOStream1 = desFile.OpenAsTextStream(iomode:=ForAppending, Format:=TristateUseDefault)
Do While Not FSOStream.AtEndOfStream
xp = FSOStream.ReadLine
FSOStream1.Write vbCrLf & xp ' vbCrLf & xp or 'xp & vbCrLf
Loop
FSOStream.Close
FSOStream1.Close
Next
erLabel:
If Err.Number = 53 Then
MsgBox "Aborted : destination file not found"
GoTo final
End If
final:
Set FSOStream = Nothing: Set FSOStream1 = Nothing: Set FSO = Nothing: Set fol = Nothing
Set fil = Nothing: Set srcFile = Nothing: Set desFile = Nothing
End Sub
N.B If works for you then mark as answer else comment end if
I'm working on a machine which runs on Windows XP but has no Office or .NET Framework installed.
I would like to have the possibility to open/save files by opening a FileDialog. Unfortunately they are not listed (in VBA editor) as a Class. How do I get to put them in my code?
The following is an example of what I use to Save (which works, but I really need filedialogs). I achieve opening files in the same way:
Sub Make_File()
Dim i As Long
Dim AnzTrace As Long
Dim SysAbstand As Double
Dim DatName, Type, Dummy As String
Dim SysDist As Double
Dim Nr, Pos, Offset, Phase As Double
Dim SysDate, SysTime As String
Dim Buff1, Buff2, Buff3 As String
Dim Day, Time As Variant
Dim AktDir As String
AktDir = CurDir
Call Shell("C:\WINDOWS\explorer " & AktDir, 1) ' I need to change folder in file explorer in order to save the file where i want...
Message1 = "Dateinamen eingeben (ohne .txt)"
Title = "Data Input"
Default1 = TXTDatName
DatName = InputBox(Message1, Title, Default1)
If DatName = "" Then
GoTo ExitMakeFile
End If
Message1 = "Kommentar eingeben"
Title = "Data Input"
Default1 = "bla bla bla"
Type = InputBox(Message1, Title, Default1)
If Type = "" Then
GoTo ExitMakeFile
End If
Message1 = "Systemabstand eingeben"
Title = "Data Input"
Default1 = "116"
SysDist = InputBox(Message1, Title, Default1)
If Dummy = Null Then
GoTo ExitMakeFile
End If
Day = SCPI.SYSTem.Date
Buff1 = Format(Day(0), "####")
Buff2 = Format(Day(1), "0#")
Buff3 = Format(Day(2), "0#")
SysDate = Buff1 & "/" & Buff2 & "/" & Buff3
Time = SCPI.SYSTem.Time
Buff1 = Format(Time(0), "0#")
Buff2 = Format(Time(1), "0#")
SysTime = Buff1 & ":" & Buff2
AnzTrace = SCPI.CALCulate(1).PARameter.Count
Dummy = " "
DatName = AktDir & "\" & DatName & ".txt"
i = AnzTrace
Open DatName For Output As #1
Print #1, AntennaType
Print #1, "Datum: " & SysDate & " " & SysTime
Buff1 = "X" & Chr(9) & "Abstand" & Chr(9) & "Kabel" & Chr(9) & "gedreht"
Print #1, Buff1
Print #1, Dummy
Do While i > 1
Pos = SysDist
Offset = 0
Phase = 0
Buff3 = Str(i) & Chr(9) & Str(Pos) & Chr(9) & Str(Offset) & Chr(9) & Str(Phase)
Print #1, Buff3
i = i - 1
Loop
Buff3 = Str(i) & Chr(9) & " 0" & Chr(9) & Str(Offset) & Chr(9) & Str(Phase)
Print #1, Buff3
Close #1
Call Shell("C:\WINDOWS\notepad " & DatName, 1)
ExitMakeFile:
End Sub
This is adapted from the msdn example. Paste it in a standard module.
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenFilename As OPENFILENAME) As Long
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenFilename As OPENFILENAME) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Sub EntryPoint()
Dim tpOpenFname As OPENFILENAME
With tpOpenFname
.lpstrFile = String(256, 0)
.nMaxFile = 255
.lStructSize = Len(tpOpenFname)
If GetOpenFileName(tpOpenFname) <> 0 Then
Debug.Print Left$(.lpstrFile, .nMaxFile)
Else
Debug.Print "Open Canceled"
End If
If GetSaveFileName(tpOpenFname) <> 0 Then
Debug.Print Left$(.lpstrFile, .nMaxFile)
Else
Debug.Print "Save Canceled"
End If
End With
End Sub
So basically I had to write the following in a Userform, then create a button named "ReadFile" and a field called "FileName".
Private Sub ReadFile_Click()
Dim tpOpenFname As ToFile
Dim lReturn As Long
Me.hide ' I hide the Userform but I can't really get a proper focus on the getOpenFile
With tpOpenFname
.lpstrFile = String(257, 0)
.nMaxFile = Len(tpOpenFname.lpstrFile)
.lStructSize = Len(tpOpenFname)
.lpstrFilter = "Text files (*.txt)" ' I want only to open txt
.nFilterIndex = 1
.lpstrFileTitle = tpOpenFname.lpstrFile
.nMaxFileTitle = tpOpenFname.nMaxFile
.lpstrInitialDir = "C:\"
.lpstrTitle = "Bitte eine Datei eingeben"
End With
lReturn = GetOpenFileName(tpOpenFname)
If lReturn = 0 Then
End
Else
Me.FileName = Left(tpOpenFname.lpstrFile, InStr(tpOpenFname.lpstrFile, ".txt") + 3)
'This is because I get silly symbols after the real filename (on "save" didn't have this problem though
End If
Me.Show
End Sub
And in the main module:
Read.Show vbModal ' to call the Userform
DatName = Read.FileName 'Read is the Userform name
Open DatName For Input As #1
As for "Save":
Private Sub SaveFile_Click()
Dim tpSaveFname As ToFile
Dim lReturn As Long
Me.hide
With tpSaveFname
.lpstrFile = String(257, 0)
.nMaxFile = Len(tpSaveFname.lpstrFile)
.lStructSize = Len(tpSaveFname)
.lpstrFilter = "Text files (*.txt)"
.nFilterIndex = 1
.lpstrFileTitle = tpSaveFname.lpstrFile
.nMaxFileTitle = tpSaveFname.nMaxFile
.lpstrInitialDir = "C:\"
.lpstrTitle = "Bitte eine Datei eingeben"
End With
lReturn = GetSaveFileName(tpSaveFname)
If lReturn = 0 Then
End
Else
Me.FileName = tpSaveFname.lpstrFile
Me.FileName = Me.FileName & ".txt"
End If
Me.Show
End Sub
And in the main module:
DatName = SaveAs.FileName 'SaveAs is the Userform name
Call Shell("C:\WINDOWS\notepad " & DatName, 1)