轉載如下：
說明一下，我這里是以星期日作為一周的開始
思路如下：
首先要計算今天離元旦相差多少天，然后除以7就得出今天離元旦多少個星期了。
這里要判斷有無余數，如果有余數，則把商加1，就得出今天相距元旦多少個星期了。
程序代碼
yuandan := @ToTime(@Text(@Year(@Now))+"-01-01");
x:= @Integer(((@Today-yuandan)/(3600*24)+1)/7);
y:=((@Today-yuandan)/(3600*24)+1)/7;
@If(y-x>0;x+1;x)
但目前算出的只是今天相距元旦的星期數，并不是真正的周次。
因為每年元旦并不都是星期日，例如2006年的元旦是星期日，則本年的第一周是完整的一周（有7天）。
如果元旦不是星期日，則本年的第一周就只有（7-星期數）天。
例如2005年的元旦是星期六，則本年的第一周只有1天，1月2號就是第二周的開始了。
所以如果只用上面的四行代碼，是不符合實際情況的。
而且上面的代碼還有bug，如果@Today是元旦，那會輸出0。
要計算真正的周次，就要從第二周開始算起。
第一周的天數是7減元旦的星期數，
如果元旦是星期日， @Weekday(yuandan)返回1，星期一返回2。
所以星期數要減一。代碼如下：
程序代碼yuandan := @ToTime(@Text(@Year(@Now))+"-01-01");
wd := @Weekday(yuandan);
t := 7-(wd-1);
用@Today 減元旦，再減第一周天數t，再加一，就是@Today到第二周開始的天數t1。
這里要做個判斷，
If @Today 就是第一周里的，那得出的結果t1就會是負數，我們可以直接輸出@Today 所在周次是第一周。
Else 用 t1除以7，得出@Today 距離第二周有多少周。 然后加上1,就是加上第一周。就得出實際的周次了。
這里還有個需求就是，一年365天，就等于52周加1天。每年的第53周與下一年的第一周其實是同一周，
所以這里的周報只算52周，如果算到第53周，就改為下一年的第一周。
具體實現就是把53改為1，然后把年份那個域的值加1。
程序代碼完整代碼如下：
程序代碼REM {獲取元旦};
yuandan := @ToTime(@Text(@Year(@Now))+"-01-01");
REM {判斷元旦是否sunday,@Weekday(sunday)=1};
wd := @Weekday(yuandan);
@If(wd=1;
@Do(
x:= @Integer(((@Today-yuandan)/(3600*24)+1)/7);
y:=((@Today-yuandan)/(3600*24)+1)/7;
@If(y-x>0;x+1;x)
);
@Do(
t := 7-(wd-1);
t1 := (@Today-yuandan)/(3600*24)-t+1;
@If(t1>0;
@Do(
x:=@Integer(t1/7);
y:=t1/7;
@If(y-x>0;z:=x+2;z:=x+1);
@If(z=53;z:=1;z);
z
);
@Do(
1
))
)
)
weekend:=@Adjust(weekstart;0;0;6;0;0;0);
星期一:
@Text(weekstart;"D2")
week:=@Adjust(weekstart;0;0;1;0;0;0);
@Text(week;"D2")
week:=@Adjust(weekstart;0;0;2;0;0;0);
@Text(week;"D2")
week:=@Adjust(weekstart;0;0;3;0;0;0);
@Text(week;"D2")
week:=@Adjust(weekstart;0;0;4;0;0;0);
@Text(week;"D2")
week:=@Adjust(weekstart;0;0;5;0;0;0);
@Text(week;"D2")
week:=@Adjust(weekstart;0;0;6;0;0;0);
@Text(week;"D2")
3.計算任意一周的周一至周日
廠家名稱 公司得分 時間
廠家A 200 @create
廠家B 300 @create
廠家a 300 @create
顯示結果：
廠家名稱 公司得分 時間
代碼如下：
問題automation服務器不能創建對象
解決辦法：如果javascript腳本中報這個錯誤是因為IE的安全設置不允許運行未標記為安全的activeX控件 更改IE的安全設置，把相應的選項打開即可。
Sub Initialize
Dim s As New NotesSession
Dim curdoc As NotesDocument
Dim curdb As NotesDatabase
Dim vw As NotesView
Dim doc As NotesDocument
Dim et As NotesViewEntry
Dim i
i=3
Set curdb=s.CurrentDatabase
Set vw=curdb.GetView("UmSafetyInfo")
Set doc=vw.GetFirstDocument
'Dim x As Variant
'tempstr=|@name([OU2];'|+curdoc.remote_user(0)+|')|
'x=Evaluate(tempstr)
'Msgbox x(0)
Print |
<script language=javascript>
var xls = new ActiveXObject ( "Excel.Application" );
//xls.visible = "false";
var xlBook = xls.Workbooks.Add;
var xlsheet = xlBook.Worksheets(1);
xls.Cells.Select;
xlsheet.Cells(2,1).Value="部門";
xlsheet.Cells(2,2).Value="姓名";
xlsheet.Cells(2,3).Value="分機";
xlsheet.Cells(2,4).Value="移動電話";
xlsheet.Cells(2,5).Value="手機小號";
xlsheet.Cells(2,6).Value="電子郵件";
xlsheet.Cells(2,7).Value="直撥電話";
xlsheet.Rows(2).Font.Bold=1;
xlsheet.Rows(2).Font.Name="宋體";
xlsheet.Range("A1","G1").MergeCells = 1;
xlsheet.Cells(1,1).Value="某某公司";
xlsheet.Range("A1","A1").HorizontalAlignment = 3
//xlsheet.Range("A2","G2").ColorIndex = 48
xlsheet.Rows(1).Font.Bold=1;
xlsheet.Rows(1).Font.Name="黑體";
xlsheet.Rows(1).Font.Size=16;
xlsheet.Rows(2).Font.Size=9;
xlsheet.Columns(1).ColumnWidth = 25
xlsheet.Columns(2).HorizontalAlignment=3
xlsheet.Columns(3).HorizontalAlignment=3
xlsheet.Columns(4).HorizontalAlignment=3
xlsheet.Columns(4).ColumnWidth = 13.63
xlsheet.Columns(5).HorizontalAlignment=3
xlsheet.Columns(6).HorizontalAlignment=3
xlsheet.Columns(6).ColumnWidth = 25
xlsheet.Columns(7).HorizontalAlignment=3
xlsheet.Columns(7).ColumnWidth = 13.63
|
Do While Not (doc Is Nothing)
Print |xlsheet.Rows(|+i|).Font.Size=9;|
Print |xlsheet.Cells(| +i+|,1).Value='|+"Mid(doc.department(0),1)"+|';|
Print |xlsheet.Cells(| +i+|,2).Value='|+"doc.name(0)"+|';|
Print |xlsheet.Cells(| +i+|,3).Value='|+"Cstr(doc.OfficeTelExt(0))"+|';|
Print |xlsheet.Cells(| +i+|,4).Value='|+"Cstr(doc.Cellphone(0))"+|';|
Print |xlsheet.Cells(| +i+|,5).Value='|+"Cstr(doc.CellphoneLittle(0))"+|';|
Print |xlsheet.Cells(| +i+|,6).Value='|+"doc.Email(0)"+|';|
Print |xlsheet.Cells(| +i+|,7).Value='|+"Cstr(doc.OfficeTel(0))"+|';|
i=i+1
Set doc=vw.GetNextDocument(doc)
Loop
Print |
xlBook.SaveAs("c:\\通訊錄.xls");
xlBook.Close ();
xls.Quit();
xls=null;
alert("已經保存在C盤 通訊錄.xls文件中");
Temp=window.location.href.toLowerCase();
Temp=Temp.substring(0,Temp.lastIndexOf(".nsf")+5)+"UmSafetyInfo?openview";
window.location=Temp;
</script>
|
End Sub
2、常用方法：
Sub Initialize
On Error GoTo errormsg
Dim session As New NotesSession
Dim cdoc As NotesDocument
Dim doc As NotesDocument
Dim view As NotesView
Dim db As NotesDatabase
Dim dc As NotesDocumentCollection
Set db=session.currentdatabase
Set cdoc=session.documentcontext
Set view=db.GetView("UmSafetyInfo")
tempDir=session.GetEnvironmentString("Directory", True) '獲取環境變量，將代理權限設低
If InStr(tempDir, "/") <> 0 And Right(tempDir, 1) <> "/" Then
tempDir = tempDir & "/domino/html/"
End If
If InStr(tempDir, "\") <> 0 And Right(tempDir, 1) <> "\" Then
tempDir = tempDir & "\domino\html\"
End If
filename="中國電信四川公司安全管理人員數據庫.xls"
filepath=tempDir & filename
Print |<script language="javascript">alert(|+filepath+|)</script>|
If Dir(filePath)<>"" Then Kill filePath
Dim excelapplication As Variant
Dim excelworkbook As Variant
Dim excelsheet As Variant
Dim i As Integer
Dim uvcols As Integer
Dim selection As Variant
Set excelapplication=CreateObject("Excel.Application")
excelapplication.statusbar="正在創建工作表，請稍等.."
excelapplication.Visible=False
Set excelWorkbook = excelApplication.Workbooks.Add
Set excelSheet = excelWorkbook.Worksheets("sheet1")
excelsheet.name="中國電信四川公司安全管理人員數據庫" '工作表的名字
Dim rows As Integer
Dim cols As Integer
Dim maxcols As Integer
Dim fieldname As String
Dim fitem As NotesItem
rows=1
excelapplication.statusbar="正在創建單元格，請稍等.."
excelapplication.Range(excelsheet.Cells(rows, 1), excelsheet.Cells
(rows, 12)).Merge '設置title跨幾行顯示
rows=2
excelsheet.Rows(2).Font.Bold=1
excelsheet.Rows(2).Font.Name="宋體"
excelsheet.Range("A1","L1").MergeCells = 1
excelsheet.Cells(1,1).Value="中國電信四川公司安全管理人員數據庫"
excelsheet.Range("A1","A1").HorizontalAlignment = 3
REM 設置風格
excelsheet.Rows(1).Font.Bold=1
excelsheet.Rows(1).Font.Name="黑體"
excelsheet.Rows(1).Font.Size=16
excelsheet.Rows(2).Font.Size=9
excelsheet.Columns(1).ColumnWidth = 25
excelsheet.Columns(2).HorizontalAlignment=3
excelsheet.Columns(3).HorizontalAlignment=3
excelsheet.Columns(4).HorizontalAlignment=3
excelsheet.Columns(4).ColumnWidth = 13.63
excelsheet.Columns(5).HorizontalAlignment=3
excelsheet.Columns(6).HorizontalAlignment=3
excelsheet.Columns(6).ColumnWidth = 25
excelsheet.Columns(7).HorizontalAlignment=3
excelsheet.Columns(7).ColumnWidth = 13.63
excelsheet.Cells(rows,1).value="單位名稱"
excelsheet.Cells(rows,2).value="分管領導"
excelsheet.Cells(rows,3).value="姓名"
excelsheet.Cells(rows,4).value="安辦職務"
excelsheet.Cells(rows,5).value="性別"
excelsheet.Cells(rows,6).value="出生年月"
excelsheet.Cells(rows,7).value="學歷"
excelsheet.Cells(rows,8).value="崗位名稱"
excelsheet.Cells(rows,9).value="是否兼職"
excelsheet.Cells(rows,10).value="兼職名稱"
excelsheet.Cells(rows,11).value="聯系電話"
excelsheet.Cells(rows,12).value="手機"
cols=12
maxcols=cols-1
excelapplication.statusbar="正在導出數據，請稍等.."
Set doc=view.Getfirstdocument()
While Not doc Is Nothing
rows=rows+1
excelsheet.Cells(rows,1).value=doc.UmDeptName(0)
excelsheet.Cells(rows,2).value=doc.UmManageLeader(0)
excelsheet.Cells(rows,3).value=doc.UmUserName(0)
excelsheet.Cells(rows,4).value=doc.UmWorking(0)
excelsheet.Cells(rows,5).value=doc.UmSex(0)
excelsheet.Cells(rows,6).value=doc.UmBirtyday(0)
excelsheet.Cells(rows,7).value=doc.UmEducation(0)
excelsheet.Cells(rows,8).value=doc.UmWorkName(0)
excelsheet.Cells(rows,9).value=doc.UmIsFullTime(0)
excelsheet.Cells(rows,10).value=doc.UmPartTimeWork(0)
excelsheet.Cells(rows,11).value=doc.UmTel(0)
excelsheet.Cells(rows,12).value=doc.UmMoblie(0)
Set doc = view.GetNextDocument(doc)
Wend
excelapplication.statusbar="數據導入完成。"
excelWorkbook.SaveAs(filePath)
excelApplication.Quit
Set excelapplication=Nothing
Print "<script>location.href='/"+ filename +"'</script>"
Exit Sub
errormsg:
MsgBox "OutExcel Error:" & Str(Erl) & " " & Error
End Sub
On Error Goto errormsg
Dim session As New notessession
Dim cdoc As notesdocument
Dim doc As notesdocument
Dim view As notesview
Dim db As notesdatabase
Dim db_user As NotesDatabase
Set db=session.currentdatabase
Set cdoc=session.documentcontext
Dim mdoc As NotesDocument
cdocUnid = cdoc.UniversalID
Set db_user = session.GetDatabase(db.Server,"sctel\lyuser.nsf")
NotesMacro$ = |@AttachmentNames|
attList = Evaluate(NotesMacro$,cdoc)
attNames = ""
For i = Lbound(attList) To Ubound(attList)
If Trim(attList(i))<> "" Then
If attNames = "" Then
attNames = attList(i)
Else
attNames = attNames + "," + attList(i)
End If
End If
Next
Set view=db.getview("SMS_showFile")
For i=0 To Ubound(cdoc.alldeptName)
If Len(Trim(cdoc.alldeptName(i)))>0 Then
key=cdocUnid+cdoc.alldeptName(i)
Msgbox "key;"+key
Set dc=view.getalldocumentsbykey(key,True)
Msgbox "dc.count:"+Cstr(dc.count)
If dc.count>0 Then
Set doc=dc.getfirstdocument
Else
Set doc = New NotesDocument(db)
Dim authorsItem As New NotesItem(doc, "Author", _
"admin", Readers)
Dim readersItem As New NotesItem(doc, "yhuser", _
Trim(cdoc.alldeptName(i)), Authors)
End If
doc.HYUNID=cdocUnid
doc.SMS_Subject=cdoc.SMS_Subject(0)
'根據人員取出部門，部門編號
Set view_user = db_user.GetView("viewShowfileByUserName")
Set doc_user = view_user.GetDocumentByKey(cdoc.alldeptName(i),True)
If Not doc_user Is Nothing Then
doc.TypeNum = doc_user.TypeNum(0)
Set view_dept = db_user.GetView("viewDeptByNum")
Set doc_dept = view_dept.getdocumentbykey(doc_user.TypeNum(0),True)
If Not doc_dept Is Nothing Then
doc.TypeName = doc_dept.Type(0)
doc.deptNa = doc_dept.Type(0)
End If
End If
Call doc.save(True,True)'存儲
Dim SendTo(1) As String
SendTo(0) = cdoc.alldeptName(i)
Call sendMessge(SendTo)
End If
Next
cdoc.htmls="消息已經發送！"
'doc.SMS_riqi=Evaluate("@Created") '重新創建時間
Call cdoc.save(True,True)'存儲
cdoc.htmls="<script>alert('發送成功！');</script>"
Exit Sub
errormsg:
Msgbox "save Error:" & Str(Erl) & " " & Error
End Sub
Sub sendMessge(SendTo As Variant)
On Error Goto processError
Dim session As New notessession
Set db=session.currentdatabase
Set cdoc=session.documentcontext
Dim doc As NotesDocument
Dim view As NotesView
Dim UserDB As NotesDatabase
Dim tel As String
Dim content As String
query = cdoc.Query_String_Decoded(0)
Dim smsitem As NotesItem
Set smsitem =cdoc.GetFirstItem("SMS_Body")
content="您好！請即時處理委機關辦公系統中的《"+cdoc.foldername(0)+":"+smsitem.Text+"》文件，謝謝！["+cdoc.PUser(0)+"]"
'Msgbox"短信內容:"+content
Dim i,j As Integer
i = 0
Set UserDB = session.GetDatabase("","sctel/lyuser.nsf")
Set view = UserDB.GetView( "cellPhoneByUser" )
content=Replace(content,">","＞")
content=Replace(content,"<","＜")
Forall p In SendTo
If p <> "" Then
'獲取處理人號碼
Set doc = view.GetDocumentByKey (p)
If Not (doc Is Nothing) Then
tel=doc.CellPhoneNumber(0)
'Msgbox "tel--->"+tel
If tel <> "" Then
Msgbox "開始測試短信"
Dim xmlhttp As Variant
Dim data, URL As String
Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
data = |<?xml version="1.0" encoding="utf-8"?>|
data = data + |<soap:Envelope xmlns:xsi=" data = data + |<soap:Body>|
data = data+|<sendMessageToNextPerson xmlns=" data = data +|<senderaddr>|+Trim(tel)+|</senderaddr>|
data = data + |<content>|+content+|</content>|
data = data + |</sendMessageToNextPerson>|
data = data + |</soap:Body>|
data = data +|</soap:Envelope>|
URL="http://localhost:82/sendSMS/gzwSendSM.asmx?op=sendMessageToNextPerson"
xmlhttp.Open "POST",url, False
xmlhttp.SetRequestHeader "Content-Type", "text/xml; charset=utf-8"
xmlhttp.SetRequestHeader "Content-Length", "length"
xmlhttp.SetRequestHeader "SOAPAction"," xmlhttp.Send(data)
Else
Msgbox "未找到號碼"
End If
Else
Messagebox "未找到號碼"
End If
End If
End Forall
Exit Sub
processError:
Dim sTemp As String
sTemp = "ini出錯行:" + Cstr(Erl()) + " 出錯信息:" + Error() + " 請與管理員聯系!"
Print |<script>alert("|+sTemp+|")</script>|
Exit Sub
End Sub
Set dc=db.Ftsearch("name",0)
'0位置為最大的查詢數，0為所有匹配的文件 FTSearch必須創建數據庫索引
Set doc=dc.Getfirstdocument()、
2、Item：
Set doc=dc.Getfirstdocument()
While Not doc Is Nothing
ForAll ritem In doc.Items
MsgBox ritem.name
End ForAll
Wend
3、取出特定的域
Set doc=view.getFirstdocument()
If doc.HashItem("yu") <> "" Then
Set item=doc.getfirstitem("yu")
Set doc=view.getNextdocument(doc)
End If
4、使用文本屬性
If doc.Hashitem("yu") <> "" Then
Set doc=dc.Getfirstdocument()
While Not doc Is Nothing
ForAll itemValue In doc.yu
itemValue = "Anonymous"
End ForAll
Set doc=dc.Getnextdocument(doc)
Wend
End If
5、獲取域值：
ForAll itemValue In doc.Getitemvalue("yu")
6、添加域
set item =new NotesItem(doc,"newYu",session.UserName)
Call doc.Appenditemvalue("newYu",Newvalue)
7、替換值：
1)、 While Not doc Is Nothing
Call doc.Replaceitemvalue("resName","newValue")
Set doc=dc.getnextdocument(doc)
Wend
2)、Set doc=dc.Getfirstdocument()
While Not doc Is Nothing
'Call doc.Replaceitemvalue("resName","newValue")
Set item =doc.Getfirstitem("yu")
While Not item Is Nothing
ForAll resitems In doc.Itemsv(0)
resitems="newVlaue"
End ForAll
doc.name= doc.Itemsv(0)
Set item =doc.getnextitem(item)
Wend
Set doc=dc.getnextdocument(doc)
Wend
8、拷貝域
Set item =doc.Getitemvalue("name")
call item.Copyitemtodocument(doc, "name")
call doc.save(true,false)
Call doc1.Copyallitems(doc2,true) ‘替換所有的
9、刪除指定的域：
1)、 For j=1 To dc.count
Set item=doc.Getitemvalue("name")
While Not item Is Nothing
Call item.Remove()
Call doc.Save(true,false)
Wend
Set doc=dc.Getnthdocument(j)
Next
2)、For j=1 To dc.count
While Not doc.Hasitem("name")
Call doc.Removeitem("name")
Call doc.Save(True,false)
Wend
Set doc=dc.Getnthdocument(j)
Next
10、RTF文本域的輸出：
Set item=doc.GetFirstItem("RtfYU")
MsgBox item.Text
11、在代理中使用公式：
ForAll csx In doc.Embeddedobjects
csx.name
End ForAll
Set doc=dc.Getnthdocument(j)
Next
13、激活嵌入對象：
Call doc.EmbeddedObjects(0).Activate(True)
14、if的用法
Set doc=dc.Getfirstdocument()
If Not IsEmpty(db.Agents) Then
ForAll agent In db.Agents
MsgBox agent.name
End ForAll
End If