Jump to content

SUBIECTE NOI
« 1 / 5 »
RSS
Incalzire casa fara gaz/lemne

Incalzire in pardoseala etapizata

Suprataxa card energie?!

Cum era nivelul de trai cam din a...
 probleme cu ochelarii

Impozite pe proprietati de anul v...

teava rezistenta panou apa calda

Acces in Curte din Drum National
 Sub mobila de bucatarie si sub fr...

Rezultat RMN

Numar circuite IPAT si prindere t...

Pareri brgimportchina.ro - teapa ...
 Lucruri inaintea vremurilor lor

Discuții despre TVR Sport HD.

Cost abonament clinica privata

Tremura toata, dar nu de la ro...
 

Buton Save and Exit

- - - - -
  • Please log in to reply
2 replies to this topic

#1
xymzar

xymzar

    Senior Member

  • Grup: Senior Members
  • Posts: 9,594
  • Înscris: 14.10.2004
Salut tuturor,am urmatoarea problema.Mentionez ca sunt paralel cu VBA-ul :confuzzled:
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.


#2
romi

romi

    Junior Member

  • Grup: Members
  • Posts: 96
  • Înscris: 20.05.2005
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


#3
xymzar

xymzar

    Senior Member

  • Grup: Senior Members
  • Posts: 9,594
  • Înscris: 14.10.2004
Multumesc Romi acum incep testarea

Anunturi

Chirurgia endoscopică a hipofizei Chirurgia endoscopică a hipofizei

"Standardul de aur" în chirurgia hipofizară îl reprezintă endoscopia transnazală transsfenoidală.

Echipa NeuroHope este antrenată în unul din cele mai mari centre de chirurgie a hipofizei din Europa, Spitalul Foch din Paris, centrul în care a fost introdus pentru prima dată endoscopul în chirurgia transnazală a hipofizei, de către neurochirurgul francez Guiot. Pe lângă tumorile cu origine hipofizară, prin tehnicile endoscopice transnazale pot fi abordate numeroase alte patologii neurochirurgicale.

www.neurohope.ro

0 user(s) are reading this topic

0 members, 0 guests, 0 anonymous users

Forumul Softpedia foloseste "cookies" pentru a imbunatati experienta utilizatorilor Accept
Pentru detalii si optiuni legate de cookies si datele personale, consultati Politica de utilizare cookies si Politica de confidentialitate