Domino使用Adodb連接庫

下面為 SourceCode

Sub Initialize
Dim s As notessession
Dim db As notesdatabase
Dim doc As notesdocument

Dim cn As Variant
Dim rs As Variant
Dim adodbstream As Variant
Dim body As notesmimeentity
Dim notesstream As notesstream

Dim tchunksize As Long
Dim i As Integer
Dim conchunk As Integer
Const conchunksize = 32767

Set s = New notessession
Set db = s.currentdatabase
s.convertmime = False ' Do not convert MIME to rich text
Set notesstream = s.createstream

Set cn = createobject("adodb.connection")
Set rs = createobject("adodb.recordset")
Set adodbstream = createobject("adodb.stream")
adodbstream.mode = 3 ' read/write
adodbstream.type = 1 ' adTypeBinary
cn.open "odbc;database=northwind;uid=sa;pwd=kevin001;dsn=localserver"
rs.open "select * from picture", cn
adodbstream.open
rs.movefirst

If Dir$("d:\temp", 16) = "" Then ' 判斷是否有本資料夾
Mkdir "d:\temp"
End If

While Not(rs.eof)
tchunksize = rs.fields("picture").actualsize
conchunk = tchunksize / conchunksize
Set doc = db.createdocument
doc.form = "picimport"
doc.filename = Cstr(rs.fields("filename").value)
If rs.fields("picture").actualsize > 0 Then ' 判斷欄位內是否有存有資料
'adodbstream.write rs.fields("picture").value
For i = 0 To conchunk ' 防止超過 notes buffer 32k byte
adodbstream.write rs.fields("picture").getchunk(conchunksize)
Next
adodbstream.savetofile "d:\temp\" + rs.fields("filename").value, 2 ' adSaveCreateOverWrite
Set body = doc.createmimeentity
Call notesstream.open("d:\temp\" + rs.fields("filename").value, "binary")
Call body.setcontentfrombytes(notesstream, "image/jpeg", enc_identity_binary)
End If
Call doc.save(False, False)
Call notesstream.close
Kill "d:\temp\" + rs.fields("filename").value ' 刪除二進制檔案
rs.movenext
Wend
Rmdir "d:\temp" ' 刪除暫存資料夾
adodbstream.close
rs.close
cn.close
s.convertmime = True ' Do not convert MIME to rich text
End Sub

 Dim ws As New NotesUIWorkspace
 Dim uidoc As NotesUIDocument
 Dim doc As NotesDocument
 Set uidoc = ws.CurrentDocument
 Set doc = uidoc.Document
 
 Dim cn As Variant
 Dim rs As Variant
 Set cn = createobject("adodb.connection")
 Set rs = createobject("adodb.recordset")
 Dim connstr As String
 ConnStr="Provider=sqloledb.1;persist security info=false;server=tserp01;uid=tatest;pwd=tatest;database=tadpcs"
 cn.open connstr
 Dim sqlstr As String
 sqlstr="SELECT ITM_BASIC_MSTR.ITMCODE, ITM_BASIC_MSTR.ITMNAME, " _
 &"ITM_BASIC_MSTR.SPEC1, ITM_BASIC_MSTR.UMCODE, UM_MSTR.NAME NAME_2, " _
 &" ITM_BASIC_MSTR.PARTTYPE, PARTTYPE_MSTR.NAME, ITM_BASIC_MSTR.ATP1, " _
 &" ADDPARTTYPE_MSTR.ADDPTNAME, ITM_BASIC_MSTR.SITECODE, " _
 &" ITM_BASIC_MSTR.REMARKS,  ' '+ITMCODE ITMCODE_2" _
 &" FROM ITM_BASIC_MSTR ITM_BASIC_MSTR" _
 &"  LEFT OUTER JOIN PARTTYPE_MSTR PARTTYPE_MSTR ON " _
 &"(PARTTYPE_MSTR.PARTTYPE = ITM_BASIC_MSTR.PARTTYPE) " _
 &" LEFT OUTER JOIN ADDPARTTYPE_MSTR ADDPARTTYPE_MSTR ON " _
 &"(ADDPARTTYPE_MSTR.ADDPTCODE = ITM_BASIC_MSTR.ATP1) " _
 &"LEFT OUTER JOIN UM_MSTR UM_MSTR ON " _
 &"(UM_MSTR.UMCODE = ITM_BASIC_MSTR.UMCODE) " _
 &"WHERE ( ITM_BASIC_MSTR.STATUS = 'IS1' ) " _
 &"AND ( ITM_BASIC_MSTR.PARTCLASS <> 'C7' ) " _
 &"AND ( ITM_BASIC_MSTR.PARTTYPE LIKE '%' ) " _
 &"AND (ITM_BASIC_MSTR.ITMCODE like '"+tstr+"%')"
 rs.open sqlstr, cn
 rs.movefirst
 Dim i As Integer,tstr1 As String
 While Not (rs.eof )
  rs.movenext
  i=i+1
  If i<10 Then
   'Msgbox Cstr(rs("ITMNAME").value)
   tstr1=rs("ITMCODE").value+"***"+Cstr(rs("ITMNAME").value)+"***"+rs("NAME_2").value+";"
   Call uidoc.FieldAppendText("RstDesp",tstr1)
  End If
 Wend
 rs.close
 Set rs=Nothing
 cn.close
 Set cn=Nothing