VBA抓取当前的文件名称及地址：
Dim str1 As String,str2 as string
str1 = Application.ActiveWorkbook.FullName
str2 = ThisWorkbook.Path
其中，str1得到的是带有文件名的路径名，str2得到的是路径名。如：
str1= "e:\test\book1.xls "
str2= "e:\test "
----------------------------------------------------------------------------------------------
取邮件签名代码：
Dim SigString As String
Dim Signature As String
SigString = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\Mysignature.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
----------------------------------------------------------------------------------------------------
自已凑出来的按流程发送通知邮件的东东：
Public Sub 询价信息1()
'Const istep As Integer = 1
Dim myscore As Integer
myscore = Range("C33").Value
Select Case myscore
Case Is < 35
MsgBox "信息不够无法评估!"
Sheets("进度示意图").Select
Range("C4").Select
Selection.FormulaR1C1 = "FALSE"
Case 35 To 60
MsgBox "重要信息已提供可通知开发部进行评估"
Call Smail(1)
End Select
Sheets("1询价信息统计").Select
' ActiveSheet.Protect
End Sub
Sub 评估完成2()
irst = MsgBox("确定已完成？", vbYesNo)
If irst = vbYes Then
Call Smail(2)
Else
Exit Sub
End sub
----------------------------
Sub Smail(k As Integer)
Dim SigString As String
Dim Signature As String
SigString = "C:\Documents and Settings\" & Environ("username") & _
"\Application Data\Microsoft\Signatures\Mysignature.txt"
If Sheets("进度示意图").Range("C" & k + 3) = False Then
Exit Sub
Else
Sheets("进度示意图").Select
Application.ScreenUpdating = False
Dim mailaddress As String
Dim i As Integer
Dim objOL As Object
Dim itmNewMail As Object
Dim Hyp As String
'Hyp = "
\\192.168.0.252\公共文档\财务\Estimation\" & ActiveWorkbook.Name
Hyp = Application.ActiveWorkbook.FullName
'Hyp = "<a href=""http:\\www.baidu.com"">Click here</a>"
For i = 1 To 1
Set objOL = CreateObject("Outlook.Application")
Set itmNewMail = objOL.CreateItem(olMailItem)
If k = 3 Or k = 4 Or k = 5 Then '流程3.4.5均需跳到下一步执行,即：3-5,4-6,5-7,是一个平行的流程
mailaddress = Range("F" & k + 5)
Else
mailaddress = Range("F" & k + 4)
End If
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If
With itmNewMail
.To = mailaddress
' .BCC = "
yss@AXILONE-SHUNHUA.CN"
.Subject = Range("B" & k + 3) & "完成" & "--" & Range("B2")
If k = 3 Or k = 4 Or k = 5 Then '流程3.4.5均需跳到下一步执行,即：3-5,4-6,5-7,是一个平行的流程
.cc = Range("G" & k + 5)
.Body = Range("E" & k + 5) & "：" & vbCrLf & "请尽快完成此项目" & Range("B" & k + 5) & "之事项" & ",谢谢！" & vbCrLf & Hyp & _
vbCrLf & vbCrLf & Signature
' .Body = Range("E" & k + 5) & "：" & vbCrLf & "请尽快完成此项目" & Range("B" & k + 5) & "之事项" & ",谢谢！" & vbCrLf & Range("E" & k + 3) & vbCrLf & Signature
Else
.cc = Range("G" & k + 4)
.Body = Range("E" & k + 4) & "：" & vbCrLf & "请尽快完成此项目" & Range("B" & k + 4) & "之事项" & ",谢谢！" & vbCrLf & Hyp & _
vbCrLf & vbCrLf & Signature
End If
' .GetInspector '邮件签名代码,但不管用还造成Word死机
.Display True
On Error Resume Next
.Send
On Error GoTo 0
Set objOL = Nothing
Set itmNewMail = Nothing
End With
Next i
Application.ScreenUpdating = True
End If
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function
------------------------------------------------
找来的可以掩码的 InputBox
'-------------------------------------------------------------------
'有输入掩码的 InputBox
'在 VBA InputBox 可以隐藏输入的字符
'-------------------------------------------------------------------
'需要引用 WIN32 API
Private Declare Function CallNextHookEx _
Lib "user32" (ByVal hHook As Long, _
ByVal ncode As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Private Declare Function GetModuleHandle _
Lib "kernel32" Alias "GetModuleHandleA" _
(ByVal lpModuleName As String) As Long
Private Declare Function SetWindowsHookEx _
Lib "user32" Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx _
Lib "user32" (ByVal hHook As Long) As Long
Private Declare Function SendDlgItemMessage _
Lib "user32" Alias "SendDlgItemMessageA" _
(ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Private Declare Function GetClassName _
Lib "user32" Alias "GetClassNameA" _
(ByVal hwnd As Long, _
ByVal lpClassName As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
'定义 API 中需要引用的常数
Private Const EM_SETPASSWORDCHAR = &HCC
Private Const WH_CBT = 5
Private Const HCBT_ACTIVATE = 5
Private Const HC_ACTION = 0
Private hHook As Long
Public Function NewProc(ByVal lngCode As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim RetVal
Dim strClassName As String, lngBuffer As Long
If lngCode < HC_ACTION Then
NewProc = CallNextHookEx(hHook, lngCode, wParam, lParam)
Exit Function
End If
strClassName = String$(256, " ")
lngBuffer = 255
If lngCode = HCBT_ACTIVATE Then '当前被激活的窗体
RetVal = GetClassName(wParam, strClassName, lngBuffer)
If Left$(strClassName, RetVal) = "#32770" Then '获取 InputBox 的类名
'用 * 星号替换文本框中显示的字符
'Asc("*") 可以替换，你可以用其他字符代替
SendDlgItemMessage wParam, &H1324, EM_SETPASSWORDCHAR, Asc("*"), &H0
End If
End If
'以下这行确保其他钩子能够被正确调用
CallNextHookEx hHook, lngCode, wParam, lParam
End Function
Public Function InputBoxDK(Prompt, _
Optional Title, _
Optional Default, _
Optional XPos, _
Optional YPos, _
Optional HelpFile, _
Optional Context) As String
Dim lngModHwnd As Long, lngThreadID As Long
lngThreadID = GetCurrentThreadId
lngModHwnd = GetModuleHandle(vbNullString)
hHook = SetWindowsHookEx(WH_CBT, AddressOf NewProc, lngModHwnd, lngThreadID)
InputBoxDK = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
UnhookWindowsHookEx hHook
End Function
Function test()
'按 ALT + F11 后插入一个模块，然后将所有代码 COPY 进去后，
'将光标停在这里，然后按 F5
' MsgBox InputBoxDK("请输入密码")
InputBoxDK ("请输入密码")
End Function
-------------------------------------------------------
