Buton Save and Exit

Salut tuturor,am urmatoarea problema.Mentionez ca sunt paralel cu VBA-ul
Intr-un excel am un buton care:
- salveaza excel-ul respectiv
- unul din  sheet-uri il salveaza in format txt
- inchide excel-ul
Acum ce doresc eu, daca se poate, ar trebui adaugata o linie care sa creeeze un director cu numele excelului si sa duca excel-ul si txt-ul in el. In momentul de fata le salveaza in radacina.
Asa arata acum codul:

Private Sub CommandButton1_Click()
    Dim Wdate, Wname, Wresp
    Sheets("MIDAS").Select
    Wdate = ActiveSheet.Range("A2").Value
    Sheets("BN_codificat").Select
    Wname = ThisWorkbook.Path() & "\" & Mid(ActiveWorkbook.Name, 1, 3) & "s" & Mid(Wdate, 1, 2) & Mid(Wdate, 4, 2)
    If IsEmpty(Wdate) Then
    Wresp = MsgBox("nu sunt date", vbOKOnly)
    Else
        ActiveWorkbook.SaveAs Filename:=Wname & ".340", _
        FileFormat:=xlTextPrinter, CreateBackup:=False
        ActiveSheet.Name = "BN_codificat"
        Sheets("BN_explicit").Select
        ActiveWorkbook.SaveAs Filename:=Wname & ".xls", _
        FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
        ReadOnlyRecommended:=False, CreateBackup:=False
        Application.Quit
    End If
       MsgBox "Salvare Reusita"
End Sub

Multumesc mult

Sa creez folderul am reusit
Dar cum sa ii dau numele excel-ului si sa le salveze in noul director inca nu.Mai sap

Edited by xymzar, 03 February 2006 - 21:51.

salut,
iti timit mai jos niste rutine scrise de mine mai demult (ultima apartine unui amic) care au darul de a te familiariza cu operatiile ce tin de fiiere si directoare; numele lor sunt destul de sugestive asa ca ma scutesc de comentarii; dc ai MSDN cauta SaveAs, bafta

Public Sub CopyFileInDir(strFileName As String, strDirName As String)
	Dim ob As Object
	Set ob = CreateObject("Scripting.FilesystemObject")
	ob.CopyFile strFileName, strDirName
	Set ob = Nothing
End Sub

Public Sub CopyFile(strOldName As String, strNewName As String)
	Dim ob As Object
	Set ob = CreateObject("Scripting.FilesystemObject")
	ob.CopyFile strOldName, strNewName
	Set ob = Nothing
End Sub

Public Sub DeleteFile(strName As String)
	Dim ob As Object
	Set ob = CreateObject("Scripting.FilesystemObject")
	ob.DeleteFile strName
	Set ob = Nothing
End Sub

Public Sub CreateDir(strDirPath As String)
	Dim ob As Object
	Set ob = CreateObject("Scripting.FilesystemObject")
	If Dir(strDirPath, vbDirectory) = "" Then
		ob.CreateFolder (strDirPath)
	Else
		MsgBox "Directory Exist"
	End If
	Set ob = Nothing
End Sub

' diverse operatii in Excel
Public Function ExcelFile(strPathFile As String) As Boolean
	Dim xlApp As New Excel.Application
	Dim xlBook As Excel.Workbook
	Dim xlSheet As Excel.Worksheet
		
	If Dir(strPathFile) <> "" Then
		Set xlApp = New Excel.Application
		Set xlBook = xlApp.Workbooks.Open(strPathFile)
		Set xlSheet = xlBook.Worksheets(1)
	
		xlBook.Sheets(1).Cells(1, 2) = 10
		
		xlSheet.Name = "anda"
		
		xlBook.Save
		xlBook.Close
		xlApp.Quit
		
		Set xlSheet = Nothing
		Set xlBook = Nothing
		Set xlApp = Nothing
		
		ExcelFile = True
	Else
		'MsgBox "Nu exista fisierul.", vbCritical, strE
		ExcelFile = False
	End If
End Function

' This procedure creates a new workbook file and saves it by using the path
' and name specified in the strBookName argument. You use the intNumsheets
' argument to specify the number of worksheets in the workbook;
' the default is 3.
Public Function CreateNewWorkbook(strBookName As String, _
	  intNumSheets As Integer) As Workbook
   
	Dim xlApp As New Excel.Application
	Dim intOrigNumSheets As Integer
	Dim wkbNew As Excel.Workbook
	
	On Error GoTo CreateNew_Err
   
	intOrigNumSheets = Application.SheetsInNewWorkbook
	If intOrigNumSheets <> intNumSheets Then
		Application.SheetsInNewWorkbook = intNumSheets
	End If
	
	Set wkbNew = Workbooks.Add
	If Len(strBookName) = 0 Then strBookName = Application.GetSaveAsFilename
	wkbNew.SaveAs strBookName
	Set CreateNewWorkbook = wkbNew
	Application.SheetsInNewWorkbook = intOrigNumSheets
	
	xlApp.Quit
   
CreateNew_End:
	Exit Function
CreateNew_Err:
	Set CreateNewWorkbook = Nothing
	wkbNew.Close False
	Set wkbNew = Nothing
	Resume CreateNew_End
End Function

Multumesc Romi acum incep testarea