Discussione: Corso VBA
Visualizza messaggio singolo
Vecchio 08-09-2014, 00.23.31   #59
Alexsandra
Senior Member
WT Expert
 
L'avatar di Alexsandra
 
Registrato: 19-05-2007
Loc.: Verona
Messaggi: 1.208
Alexsandra Ŕ un gioiello raroAlexsandra Ŕ un gioiello raroAlexsandra Ŕ un gioiello raroAlexsandra Ŕ un gioiello raro
#6

Macro e Procedure varie riferite ai File


=> Crea un file txt
Codice:
Sub messaggio()
Sheets.Add
ActiveSheet.Move
Dim MiaUn As String
MiaUn = Left(CurDir, 3)
ActiveWorkbook.SaveAs Filename:=MiaUn & "Messaggio", FileFormat:=xlTextMSDOS, CreateBackup:=False
Cells(2, 1) = "Ragione Sociale"
Cells(2, 2) = Application.OrganizationName
Cells(3, 1) = "e-mail"
Cells(4, 1) = "telefono"
Cells(4, 2) = "quello che vuoi"
Cells(6, 2) = "altri dati, oggetto o quello che vuoi"
Cells(7, 2) = "testo del messaggio"
Cells(8, 2) = "altro testo"
Cells(9, 2) = "ancora testo"
ActiveWindow.Zoom = 85
Columns(1).ColumnWidth = 18
Columns(2).ColumnWidth = 50
Columns(3).ColumnWidth = 50
Range("B3:B4").Select
Selection.Font.Size = 16
Selection.Interior.ColorIndex = 34
Selection.Locked = False
ActiveWindow.DisplayGridlines = False
ActiveWindow.DisplayHeadings = False
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
End Sub
=> Verifica se un file Ŕ giÓ aperto prima di salvarlo
Codice:
Sub test()
nome = InputBox("Nome")
flag = 0
For Each p In Workbooks
If w.Name = pippo Then
flag = 1
End If
Next w
If flag = 1 Then
MsgBox ("Il file esiste")
Else
MsgBox ("File inesistente")
End If
End Sub
=> Scrivere in un file txt
Codice:
Sub scrivi()
Open "C\:prova.txt" For Output As #1
r = 1
Print #1, "Nel magazzino ho:"
While Cells(r, 1) <> ""
Print #1, Cells(r, 2); " "; Cells(r, 1)
r = r + 1
Wend
Close #1
End Sub
=> Distruggere un file
Nota: Attenzione, questa macro distrugge il file per sempre
Codice:
Sub Distruzione()
Dim FName As String, Ndx As Integer
With ThisWorkbook
.Save
For Ndx = 1 To Application.RecentFiles .Count
If Application.RecentFiles(Ndx).Path = .FullName Then
Application.RecentFiles(Ndx).Delete
Exit For
End If
Next Ndx
.ChangeFileAccess Mode:=xlReadOnly
Kill .FullName
.Close SaveChanges:=False
End With
End Sub
=> Vedere le proprietÓ del documento
Codice:
 Sub Prop_doc()
rw = 1
Worksheets.Add
On Error Resume Next
For Each p In ActiveWorkbook.BuiltinDocumentProperties
Cells(rw, 1).Value = p.Name
Cells(rw, 2).Value = p.Type
Cells(rw, 3).Value = p.Value
rw = rw + 1
Next
End Sub
=> Elencare le proprieta di un file
Nota: Ritorna tutte le proprietÓ della cartella attiva.
Codice:
Sub Proprieta()
Dim I As Integer, txt As String
Sheets.Add
On Error Resume Next
With ThisWorkbook.BuiltinDocumentProperties
For I = 1 To .Count
Cells(I, 1) = .Item(I).name
Cells(I, 2) = .Item(I)
Next I
End With
Cells(I + 2, 1) = FileLen(ThisWorkbook.FullName) & " octets"
Columns("A:B").AutoFit
[B11:B12].NumberFormat = "dd/mm/yyyy hh:mm:ss"
End Sub

'altro metodo

Sub TestInfos()
MsgBox ShowFileInfos(ThisWorkbook.FullName)
End Sub

Function ShowFileInfos(filespec)
Dim fso, f, s
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(filespec)
s = UCase(filespec) & vbLf
s = s & "Creato il : " & f.DateCreated & vbLf
s = s & "Ultimo accesso il : " & f.DateLastAccessed & vbLf
s = s & "Ultima modifica il : " & f.DateLastModified & vbLf
s = s & "Tipo di file : " & f.Type & vbLf
s = s & "Taglia : " & f.Size
ShowFileInfos = s
End Function
=> Copiare il contenuto di un file senza aprirlo
Codice:
Sub CopyAllFiles()
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
oFso.CopyFile "C:\1BACK\*.*", "M:\2BACK\", True
MsgBox ("ok fatto")
End Sub

Sub CopyOneFiles()
Dim oFso As Object
Set oFso = CreateObject("Scripting.FileSystemObject")
oFso.CopyFile "C:\1BACK\pippo.xls", "M:\2BACK\", True
MsgBox ("ok fatto")
End Sub
___________________________________

- Il primo fondamento della sicurezza non e' la tecnologia, ma l'attitudine mentale -
Alexsandra non Ŕ collegato