Codice sorgente VBA vario

=> Visualizzare la cella vuota contenete il valore “0″
Sub Sostituzione_zeri()
Dim P As Object
For Each P In Selection
If P.Value = 0 Then
P.NumberFormat = “;;;”
End If
Next P
End Sub
** Selezionare prima l’intervallo che contiene le celle vuote

=> Eseguire un programma con “ritardo”
Sub Test()
Sleep NumSeconds:=10
Shell (”percorso e nome programma”)
End Sub

Sub Sleep(NumSeconds As Single)
Dim StartTime As Single
StartTime = Timer
While (Timer - StartTime) < NumSeconds
DoEvents
Wend
End Sub

=> Verifica se un file è già aperto prima di salvarlo
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

=> Inviare email da Outlook con VBA
Sub SendMail()
Set myOutlook = CreateObject(”Outlook.Application”)
Set mymail = myOutlook.CreateItem(olMailItem)
mymail.Subject = “Inserire testo Oggetto”
mymail.Body = “Inserire testo da inviare”
mymail.Recipients.Add (”Indirizzo email”)
mymail.Send
End Sub

=> Aggiungere del testo in una cella in cui è presente altro testo
Sub Testo()
Dim addr1 As String
Dim addr2 As String
Dim cel As Range
Dim box As String
Range(”B2:B11″).Select
box = Range(”d4″).Value
Application.ScreenUpdating = False
addr1 = ActiveCell.Address
addr2 = ActiveCell.End(xlDown).Address
Range(addr1 & “:” & addr2).Select
For Each cel In Selection
cel.Value = cel.Value & ” ” & box
Next cel
Range(addr1).Select
End Sub

=> Ottenere la lista di cartelle e sotto-cartelle del disco
Dim count, dircount, totaldir As Integer
Dim filename As String
Dim dirnames()

Sub tree()
Workbooks.Add
totaldir = 0
dircount = 0
count = 1
mydir = InputBox(”Inserire la directory”)
AddDir (mydir)
Worksheets(1).Range(”a1″) = UCase(mydir)
Do While UBound(dirnames, 1) > dircount
dircount = dircount + 1
filename = Dir(dirnames(dircount), vbDirectory)
Do While filename <> “”
If Left(filename, 1) <> “.” Then
count = count + 1
file = dirnames(dircount) & filename
If GetAttr(file) = vbDirectory Then
Worksheets(1).Cells(count, 1).Value = _
dirnames(dircount) & filename
AddDir (file)
Else
count = count - 1
End If
End If
filename = Dir()
Loop
Loop
End Sub

Sub AddDir(dirname As String)
totaldir = totaldir + 1
ReDim Preserve dirnames(totaldir)
If Right(dirname, 1) = “\” Then
dirnames(totaldir) = UCase(dirname)
Else
dirnames(totaldir) = UCase(dirname & “\”)
End If
End Sub

=> Barra menu con vba
Option Explicit

Sub Auto_Open()
Dim Etichetta(1 To 3)
Dim Comando(1 To 3)
Dim Nomemenu As String

Nomemenu = “&Menù Alex”
Etichetta(1) = “Esegui Macro 1″
Comando(1) = “macro1″
Etichetta(2) = “Esegui Macro 2″
Comando(2) = “macro2″
Etichetta(3) = “Esegui Macro 3″
Comando(3) = “macro3″ On Error Resume Next
MenuBars(xlWorksheet).Menus(Nomemenu).Delete
MenuBars(xlWorksheet).Menus.Add Caption:=Nomemenu, before:=”Help”

With MenuBars(xlWorksheet).Menus(Nomemenu).MenuItems
.Add Caption:=Etichetta(1), OnAction:=Comando(1)
.Add Caption:=Etichetta(2), OnAction:=Comando(2)
.Add Caption:=Etichetta(3), OnAction:=Comando(3)
End With
End SubSub

Auto_Close()
Dim Nomemenu As String
Nomemenu = “&Menù Alex”

‘ cancella il menù quando esci
On Error Resume Next
MenuBars(xlWorksheet).Menus(Nomemenu).Delete
End Sub

Sub macro1()
MsgBox “Ho eseguito la Macro 1″
End Sub

Sub macro2()
MsgBox “Ho eseguito la Macro 2″
End Sub

Sub macro3()
MsgBox “Ho eseguito la Macro 3″
End Sub

=> Conoscere nome Pc
Private Declare Function api_GetUserName Lib “advapi32.dll” Alias _
“GetUserNameA” (ByVal lpBuffer As String, nSize As Long) As Long
Private Declare Function api_GetComputerName Lib “Kernel32″ Alias _
“GetComputerNameA” (ByVal lpBuffer As String, nSize As Long) As Long

Sub StampaDati()
Dim NBuffer As String
Dim Buffsize As Long
Dim wOK As Long

Buffsize = 256
NBuffer = Space$(Buffsize)

wOK = api_GetUserName(NBuffer, Buffsize)
Utente = Trim$(NBuffer)
wOK = api_GetComputerName(NBuffer, Buffsize)
computer = Trim$(NBuffer)
computer = Left$(computer, Len(computer) - 3) ‘ Elimina ultimi caratteri (danno fastidio a msgbox)
MsgBox (”Computer ‘” & computer & “‘ in uso da parte di ‘” & Utente & “‘”)
End Sub

=> Link email in una Userform
Private Sub lblMail_Click()
Link = “mailto:president@whitehouse.gov”
On Error GoTo NoCanDo
ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
Unload Me
Exit Sub
NoCanDo:
MsgBox “Cannot open ” & Link
End Sub

=> Link sito web in una Userform
Private Sub lblWeb_Click()
Link = “http://www.whitehouse.gov”
On Error GoTo NoCanDo
ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
Unload Me
Exit Sub
NoCanDo:
MsgBox “Cannot open ” & Link
End Sub