' path has the Windows reference to files. Currently they are ' path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" ' urlpath = "file:///C:/Documents%20and%20Settings/Administrator/My%20Documents/U3A_Membership_Database/" ' modify each instance to reflect your set up ' do a find to locate each instance and overwrite ' ' ------------------------------------------------------------------------- ' Sub ValidateRenewals ' this validates the content in the Renewal form ' it uses the address key from the form as the sql key to the three tables Dim TopForm As Object TopForm = ThisComponent.DrawPage.Forms.GetByName("MainForm") oCtl=TopForm.GetByName("ADDKEY") Ky = oCtl.CurrentValue Dim Context Dim DB Dim Conn Dim Stmt Dim strSQL As String Dim strSQL2 As String Dim Strng As String Dim Mbr_date As Date Dim Mshp_date As Date Dim New_date As Date dim d,m,y, dte as string Dim chng As Integer Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() Mbrs = 0 ' count of members at that address Errs = 0 ' becomes 1 if errors found chng = 0 ' is 0 initially and becomes 1 when date change required ' validate Membership strSQL= "SELECT ADDKEY, LINE1, POST_CODE, EMAIL, NEWS_LETTER, MEMBERSHIP_TYPE, LATEST_JOIN_DATE " _ & " FROM MEMBERSHIP WHERE ADDKEY = "& Ky &"" Result=Stmt.executeQuery(strSQL) While Result.next() Mtype = Result.getString(6) ' membership type, needed in Member validation If Result.getString(2) = "" Then ' Line 1 is blank Strng = Strng & "Address line 1 is blank" & chr(13) Errs = 1 End if If Result.getString(3) = "" Then ' Post code is blank Strng = Strng & "Post code is blank" & chr(13) Errs = 1 End if If Result.getString(5) <> "E" and Result.getString(5) <> "A4" and Result.getString(5) <> "A3" Then ' Newsletter type is not valid Strng = Strng & "Newsletter is not E A4 or A3" & chr(13) Errs = 1 End if If Result.getString(6) <> "Joint" and Result.getString(6) <> "Single" and Result.getString(6) <> "Free" Then ' incorrect membership type Strng = Strng & "Membership type is not Joint Single Free" & chr(13) Errs = 1 End if If Result.getString(5) = "E" and Result.getString(4) = "" Then ' Newsletter type is E but no email address Strng = Strng & "Newsletter is E but there is no email address" & chr(13) Errs = 1 End if Mshp_date = Result.getString(7) ' latest join date in Membership Wend ' validate Member(s) M1 = 0 ' first member M2 = 0 ' second member strSQL= "SELECT ADD_KEY, MEMBER_NO, TITL, FIRST_NAME, SURNAME, SEX, STATUS, JOIN_DATE "_ & " FROM MEMBER WHERE ADD_KEY = "& Ky &"" Result=Stmt.executeQuery(strSQL) While Result.next() Mbrs = Mbrs+1 ' count of members at the address If Result.getString(3) = "" Then ' title is blank Strng = Strng & "Title for member " & Result.getInt(2) & " is blank" & chr(13) Errs = 1 End if If Result.getString(4) = "" Then ' first name is blank Strng = Strng & "First name for member " & Result.getInt(2) & " is blank" & chr(13) Errs = 1 End if If Result.getString(5) = "" Then ' surname is blank Strng = Strng & "Surname for member " & Result.getInt(2) & " is blank" & chr(13) Errs = 1 End if If Result.getString(6) = "" Then ' sex is blank Strng = Strng & "Sex for member " & Result.getInt(2) & " is not M or F" & chr(13) Errs = 1 End if If Result.getString(7) <> "A" and Result.getString(7) <> "D" Then ' status is incorrect Strng = Strng & "Status for member " & Result.getInt(2) & " is not A or D" & chr(13) Errs = 1 End if Mbr_date = Result.getString(8) If Mbr_date = 0 and Result.getInt(2) > 3000 Then ' Join date is absent and recent member Strng = Strng & "Join date for member " & Result.getInt(2) & " is absent" & chr(13) Errs = 1 End if ' the member(s) at the address - one of them pays the subscription If M1 = 0 then M1 = Result.getInt(2) else M2 = Result.getInt(2) end if ' find latest join date required for welcome letter If Mbr_date > Mshp_date and Mbr_date > New_date Then ' member date > membership date and temp date New_date = Mbr_date chng = 1 end if Wend If Mbrs = 2 and Mtype <> "Joint" Then ' two members at same address so must be Joint Strng = Strng & "Members are two but Membership Type is not Joint" & chr(13) Errs = 1 else If Mbrs = 1 and Mtype <> "Single" and Mtype <> "Free" Then ' one member at same address so must be Single/Free Errs = 1 Strng = Strng & "Members are one but Membership Type is not Single" & chr(13) else If Mbrs > 2 Then ' more than two members at the same address Strng = Strng & "More than two Members at one address" & chr(13) Errs = 1 end if end if end if ' validate Subscription strSQL= "SELECT MEMBERSHIP.ADDKEY, MEMNO, GIFT_AID, SUBSCRIPTION.SUBSCRIPTION, SUB_YEAR, " _ & " SUBSCR_DATE, PL_MEMBERSHIP_TYPE_SUB.SUBSCRIPTION FROM SUBSCRIPTION, MEMBERSHIP, PL_MEMBERSHIP_TYPE_SUB "_ & " WHERE ( SUBSCRIPTION.ADDKEY = "& Ky &" AND MEMBERSHIP.ADDKEY = "& Ky &" AND TYPE = MEMBERSHIP_TYPE )" Result=Stmt.executeQuery(strSQL) While Result.next() If Result.getString(3) <> "Y" and Result.getString(3) <> "N"Then ' gift aid is blank Strng = Strng & "Gift aid is not Y or N" & chr(13) Errs = 1 End if If Result.getInt(4) <> Result.getInt(7) Then ' subscription Strng = Strng & "Subscription recorded is not consistent with expected subscription of " & Result.getInt(7) & chr(13) Errs = 1 End if Dte = Result.getString(6) If Result.getString(6) = "" Then ' payment date Strng = Strng & "Payment date is absent" & chr(13) Errs = 1 End if If Result.getInt(5) = 0 Then ' subscription year Strng = Strng & "Subscription year is blank" & chr(13) Errs = 1 End if ' to check the Subscription year Dim Sub_mth As Integer Dim Sub_yr As Integer Dte = Result.getString(6) Sub_mth = Mid(Dte,6,2) Sub_yr = Mid(Dte,1,4) If Sub_mth > 5 Then ' date is June or later Sub_yr = Sub_yr + 1 end if If Result.getInt(5) <> 0 Then ' Subscription year is blank so avoid next test else If Result.getInt(5) <> Sub_yr Then ' Subscription year is incorrect Strng = Strng & "Subscription year is " & Result.getInt(5) & " and should be " & Sub_yr & chr(13) Errs = 1 End if End if a = Result.getInt(2) If Result.getInt(2) <> M1 and Result.getInt(2) <> M2 then Strng = Strng & "The member number " & Result.getInt(2) & _ " recorded paying the subscription is not one of the members at that address" & chr(13) Errs = 1 end if Wend ' this updates LATEST_JOIN_DATE to the latest date in the memerbs for that membership - required for Welcome letter If chng = 1 Then ' is 1 if date change required d = Mid(New_date,1,2) m = Mid(New_date,4,2) y = Mid(New_date,7,4) dte = y &"-"& m &"-"& d strSQL2 ="UPDATE MEMBERSHIP SET LATEST_JOIN_DATE = '" & dte & "' WHERE ADDKEY = "& Ky &" " Stmt.executeUpdate(strSQL2) End if ' beep beep If Errs = 1 Then ' errors found Msgbox Strng else Msgbox "All data is valid" End if End Sub ' ' ---------------------------------------------------------- ' Sub ValidateMember '(Event As Object) ' (Event etc seems to be optional - it worked without it ' I used a push button to do this and it worked TopForm = ThisComponent.DrawPage.Forms.GetByName("MainForm") Val1 = TopForm.GetByName("fmtMEMBER_NO").Text Dim Mbr_no As Integer Mbr_no = Val1 Val1=TopForm.GetByName("txtFIRST_NAME").Text ' .Text required to get the content Val2=TopForm.GetByName("txtSURNAME").Text Val3=TopForm.GetByName("JOIN_DATE").Date ' 3/3/08 played back as 20080303 Val4=TopForm.GetByName("ComboBox").Text ' Sex box Val5=TopForm.GetByName("ComboBox1").Text ' Status box Val6=TopForm.GetByName("ComboBox2").Text ' Title box If Val6 = "" Then ' title is blank Strng = Strng & "Title is blank" & chr(13) Errs = 1 End if If Val1 = "" Then ' first name is blank Strng = Strng & "First name is blank" & chr(13) Errs = 1 End if If Val2 = "" Then ' surname is blank Strng = Strng & "Surname is blank" & chr(13) Errs = 1 End if If Val4 = "" Then ' sex is blank Strng = Strng & "Sex is not M or F" & chr(13) Errs = 1 End if If Val5 <> "A" and Val5 <> "D" Then ' status is incorrect Strng = Strng & "Status is not A or D" & chr(13) Errs = 1 End if If Val3 = 0 and Mbr_no > 3000 Then ' Join date is absent and recent member Strng = Strng & "Join date is absent" & chr(13) Errs = 1 End if beep If Errs = 1 Then Msgbox Strng Else MsgBox "Input is valid" endif End Sub ' ' ------------------------------------------------------------------- ' Sub Find_Empty_Memberships ' this finds those memberships where there are no longer any members ' eg there was one but, during the year, he/she has died/departed Dim Context Dim DB Dim Conn Dim Stmt Dim strSQL As String Dim Strng As String Cnt = 0 Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEMBERSHIP.ADDKEY, MEM1NO, MEM2NO FROM MEMBERSHIP " _ & "LEFT OUTER JOIN MEMBERS_MERGED ON MEMBERS_MERGED.KEY = MEMBERSHIP.ADDKEY" Result=Stmt.executeQuery(strSQL) While Result.next() If (Result.getInt(2) = 0 and Result.getInt(3) = 0) Then 'got an empty membership Strng = Strng & "Membership with address key of " & Result.getString(1) & " has no members" & chr(13) Cnt = Cnt + 1 End If Wend If Cnt <> 0 Then MsgBox Strng & chr(13) & "Completed" else Msgbox "Completed with no empty memberships" End if End sub ' ' ----------------------- ' Sub Remove_Non_Renewals ' to remove the non-renewed members as aprt of the Renewal cycle Dim iNumber As Integer Dim oNumber As Integer Dim AddKey As Integer Dim aFile As String Dim bFile As String Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() aFile = path & "NonRenewals.txt" iNumber = Freefile Open aFile For Output As #iNumber strSQL= "SELECT MEMBERSHIP.ADDKEY, SUBSCRIPTION.ADDKEY FROM MEMBERSHIP LEFT OUTER JOIN " _ +" SUBSCRIPTION ON SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY" Result=Stmt.executeQuery(strSQL) While Result.next() AddKey = Result.getInt(1) If Result.getInt(2) = 0 Then ' is null if a non-renewal Print #iNumber, Result.getInt(1) End if Wend Close #iNumber ' read the above file and delete the memberships bFile = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\NonRenewals.txt" oNumber = Freefile Open bFile For Input As #oNumber Do While not eof(oNumber) ' read the records Line Input #oNumber, CurrentLine AddKey = CurrentLine strSQL= "DELETE FROM MEMBERSHIP WHERE ADDKEY = "& Addkey &"" Result=Stmt.executeQuery(strSQL) Loop Close #oNumber Msgbox "Completed" End sub ' ' ----------------------- ' Sub Remove_Subscriptions Extract_Subscriptions Delete_Subscriptions MsgBox "Completed" End sub ' ' ----------------------- ' Sub Delete_Subscriptions ' this will delete each subscription on the Subscriptions.txt file Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() MFilename = path & "Subscriptions.txt" MFileNo = Freefile Open MFilename For Input As #MFileNo Do While not eof(MFileNo) ' read the records Line Input #MFileNo, CurrentLine Sub_key = CurrentLine strSQL= "DELETE FROM SUBSCRIPTION WHERE ID = "& Sub_key &"" Result=Stmt.executeQuery(strSQL) Loop Close #MFileNo End Sub ' ' ----------------------- ' Sub Extract_Subscriptions ' this will output a record for each subscription and write a record for each to be deleted ' but not for the June/August joiners Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim iNumber As Integer Dim aFile As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" SubYear = InputBox("Please enter the Subscription year to be deleted", "Remove subscriptions", "") 'the year to be deleted If SubYear = "" Then Msgbox "Input not valid" End If rec_read = 0 ' count of records read rec_to_delete = 0 ' open the file for output aFile = path & "Subscriptions.txt" iNumber = Freefile Open aFile For Output As #iNumber 'open a blank spreadsheet oDesk = createUnoService ("com.sun.star.frame.Desktop") oURL = "private:factory/scalc" oDoc = oDesk.loadComponentFromURL (oURL, "_blank", 0, Array() ) oSheet = oDoc.sheets(0) ' the first sheet ' access the database Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEMNO, GIFT_AID, SUBSCRIPTION, SUB_YEAR, SUBSCR_DATE, TITL, FIRST_NAME, SURNAME, LINE1, LINE2, LINE3, " _ & " POST_CODE, MEMBERSHIP_TYPE, SUBSCRIPTION.ID FROM SUBSCRIPTION, MEMBER, MEMBERSHIP WHERE (MEMNO = MEMBER_NO AND MEMBER.ADD_KEY = MEMBERSHIP.ADDKEY " _ & " AND SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY)ORDER BY MEMNO ASC" Result=Stmt.executeQuery(strSQL) While Result.next() rec_read = rec_read +1 If SubYear = Result.getString(4) Then rec_to_delete = rec_to_delete + 1 ' write each record to a new line except for the June/August joiners oCell = oSheet.getCellByPosition (0,i) oCell.Value = Result.getInt(1) 'the member no in first col oCell = oSheet.getCellByPosition (1,i) oCell.String = Result.getString(2) 'gift aid in second etc oCell = oSheet.getCellByPosition (2,i) oCell.Value = Result.getString(3) oCell = oSheet.getCellByPosition (3,i) oCell.String = Result.getString(4) oCell = oSheet.getCellByPosition (4,i) oCell.String = Result.getString(5) oCell = oSheet.getCellByPosition (5,i) oCell.String = Result.getString(6) oCell = oSheet.getCellByPosition (6,i) oCell.String = Result.getString(7) oCell = oSheet.getCellByPosition (7,i) oCell.String = Result.getString(8) oCell = oSheet.getCellByPosition (8,i) oCell.String = Result.getString(9) oCell = oSheet.getCellByPosition (9,i) oCell.String = Result.getString(10) oCell = oSheet.getCellByPosition (10,i) oCell.String = Result.getString(11) oCell = oSheet.getCellByPosition (11,i) oCell.String = Result.getString(12) oCell = oSheet.getCellByPosition (12,i) oCell.String = Result.getString(13) ' at this point write a record for the above NB June/August joiners sre excluded Print #iNumber, Result.getInt(14) ' the subscription key i = i+1 End if ' to match the If excluding June/August joiners Wend Close #iNumber ' save as calc document with the Subscription as part of the file name cFile = path & "Subscription_Data_" & SubYear &"" cURL = ConvertToURL( cFile + ".ods" ) ' saves as a calc document oDoc.storeAsURL( cURL, Array() ) If rec_to_delete = 0 then ' no records matching the input Strng1 = "No records matched the input of " & SubYear & chr(13) Strng2 = "Process stopped - remember to delete the Calc file" Msgbox Strng1 & Strng2 End else if rec_to_delete < 0.1 * rec_read then ' deletes is too high Strng1 = "No of records matching " & SubYear & " is " & rec_to_delete & " and is too low" & chr(13) Strng2 = "Process stopped - remember to delete the Calc file" Strng3 = "The wrong year has been input" & chr(13) Msgbox Strng1 & Strng3 & Strng2 End End if end if End Sub ' ' ------------------------------------------------------- ' Sub Validate ' as I have not found out how to cross validate data in a form it has to be done later Dim Context Dim DB Dim Conn Dim Stmt Dim strSQL As String Dim Strng As String Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() ' this is testing for joint/single inconsistencies strSQL= "SELECT MEMBERSHIP_TYPE, MEM1NO, MEM2NO FROM MEMBERSHIP," _ +" MEMBERS_MERGED WHERE MEMBERSHIP.ADDKEY = MEMBERS_MERGED.KEY ORDER BY MEM1NO ASC" Result=Stmt.executeQuery(strSQL) While Result.next() Membership_Type = Result.getString(1) Mem1 = Result.getInt(2) Mem2 = Result.getInt(3) ' this is to check if number of memebrs is consistent with Membership Type If Membership_Type = "Joint" and Mem2 = 0 Then Strng = Strng & "A Joint membership with only one member whose number is " & Mem1 & chr(13) Else If Membership_Type = "Single" and Mem2 <> 0 Then Strng = Strng & "A Single membership with two members whose number is " & Mem1 & chr(13) End If End If Wend ' this is testing for subscription inconsistencies strSQL= "SELECT MEMBERSHIP_TYPE, MEMNO, SUBSCRIPTION.SUBSCRIPTION, PL_MEMBERSHIP_TYPE_SUB.TYPE, " _ +" PL_MEMBERSHIP_TYPE_SUB.SUBSCRIPTION FROM SUBSCRIPTION, MEMBERSHIP, PL_MEMBERSHIP_TYPE_SUB " _ + " WHERE (SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY AND PL_MEMBERSHIP_TYPE_SUB.TYPE = MEMBERSHIP.MEMBERSHIP_TYPE) " _ + " ORDER BY MEMNO ASC" Result=Stmt.executeQuery(strSQL) While Result.next() Membership_Type = Result.getString(1) Mem = Result.getInt(2) PaidSub = Result.getInt(3) Membership_Type_Paid = Result.getString(4) Membership_Type_Sub = Result.getInt(5) ' this is to check if number of memebrs is consistent with Membership Type If Membership_Type = Membership_Type_Paid Then If PaidSub = Membership_Type_Sub Then else Strng = Strng & "Payment and Membership type is inconsistent for member " & Mem & chr(13) End if End If Wend MsgBox Strng & chr(13) & " Completed", ,"Validation" End Sub ' ' ----------------------- ' Sub Extract_Members ' this reads one row at a time and writes a smaller record containing ADD_KEY, MEMBER_NO, TITL, FIRST_NAME and SURNAME ' this used to read MEMBER_SORTED now the sql is within the string and writes one record for each database row ' this removes D status members Dim iNumber As Integer Dim aFile As String Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() aFile = path & "Member.txt" iNumber = Freefile Open aFile For Output As #iNumber strSQL= "SELECT ADD_KEY, MEMBER_NO, TITL, FIRST_NAME, SURNAME FROM MEMBER WHERE STATUS <> 'D' ORDER BY ADD_KEY ASC, MEMBER_NO ASC" Result=Stmt.executeQuery(strSQL) While Result.next() ' to replace a ' within the first name with '' First = Result.getString(4) L = Len(First) L1 = InStr(First, "'") If L1 <> 0 Then 'got a first name without a ' in it Part1 = Left(First,L1-1) Part2 = Right(First,L-L1) First = Part1 & "''" & Part2 Endif ' to replace a ' within the second name with '' Secnd = Result.getString(5) L = Len(Secnd) L1 = InStr(Secnd, "'") If L1 <> 0 Then 'got a first name without a ' in it Part1 = Left(Secnd,L1-1) Part2 = Right(Secnd,L-L1) Secnd = Part1 & "''" & Part2 Endif Print #iNumber, Result.getInt(1)&","&Result.getInt(2)&",'"&Result.getString(3)&"','"& First &"','"& Secnd &"'" ' the ' are added to strings so that SQL accepts them as valid "tokens" Wend Close #iNumber End Sub ' ' ----------------------- ' Sub Merge_Members ' to merge the rows for two members into one ' got to include code to empty the table Dim MFileNo As Integer Dim MCurrentLine As String Dim MFile As String Dim Str1 As String Dim Str2 As String Dim Str1key As Integer Dim Str2key As Integer Dim OutString As String Dim Name1 As String Dim Name2 As String ' for db access DIM Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim strValues As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() MFilename = path & "Member.txt" MFileNo = Freefile Open MFilename For Input As #MFileNo Cnt = 0 ' count of reads prior to compare Do While not eof(MFileNo) ' read the records Line Input #MFileNo, CurrentLine Cnt = Cnt + 1 ' to split out the first two lines If Cnt = 1 Then Str1 = CurrentLine Else Str2 = CurrentLine ' input1' strings=Split (Str1, ",") Add1key = strings(0) MemKey1 = strings(1) Title1 = strings(2) First1 = strings(3) Sur1 = strings(4) ' strings=Split (Str2, ",") Add2key = strings(0) MemKey2 = strings(1) Title2 = strings(2) First2 = strings(3) Sur2 = strings(4) ' If Add1key = Add2key Then 'MsgBox "merge "& Add1key & " and "& Add2key 'MsgBox " 1 "& Add1res & " - 2 "& Add2res OutString = Add1key & "," & MemKey1 &"," & Title1 &"," & First1 &"," & Sur1 & "," & MemKey2 &"," & Title2 &"," & First2 &"," & Sur2 strSQL="INSERT INTO MEMBERS_MERGED (KEY,MEM1NO,TITLE1,FIRST1,SECOND1,MEM2NO,TITLE2,FIRST2,SECOND2) VALUES("& OutString &")" Stmt.executeUpdate(strSQL) Str1 = "" Str2 = "" Cnt = 0 Else 'MsgBox "output " & Str1 OutString = Add1key & "," & MemKey1 &"," & Title1 &"," & First1 &"," & Sur1 strSQL="INSERT INTO MEMBERS_MERGED (KEY,MEM1NO,TITLE1,FIRST1,SECOND1) VALUES("& OutString &")" Stmt.executeUpdate(strSQL) Str1 = Str2 Str2 = "" Cnt = 1 End If End If ' to match the Ifs on Cnt Loop If cnt = 1 Then 'when cnt is not 1 then all records dealt with strings=Split (Str1, ",") Add1key = strings(0) MemKey1 = strings(1) Title1 = strings(2) First1 = strings(3) Sur1 = strings(4) ' OutString = Add1key & "," & MemKey1 &"," & Title1 &"," & First1 &"," & Sur1 strSQL="INSERT INTO MEMBERS_MERGED (KEY,MEM1NO,TITLE1,FIRST1,SECOND1) VALUES("& OutString &")" Stmt.executeUpdate(strSQL) End If Close #MFileNo End Sub ' '------------------------------------------------------------------------------ ' 'This extracts the data required to create the contents for the INDEX field Sub Create_Index_Table Delete_Contents_Members_Merged Extract_Members Merge_Members Extract_Index Write_Index Msgbox "Completed" End Sub ' ' ----------------------- ' Sub Extract_Index ' this reads the sorted query and writes one record with the Address key and a count Dim iNumber As Integer Dim aFile As String Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() aFile = path &"Index.txt" iNumber = Freefile Open aFile For Output As #iNumber cnt = 0 strSQL= "SELECT * FROM MEMBERS_MERGED ORDER BY SECOND1" 'this sorts MEMBERS_MERGED by Surname alphabetically Result=Stmt.executeQuery(strSQL) While Result.next() cnt = cnt + 1 Print #iNumber, cnt & "," & Result.getInt(1) Wend Close #iNumber 'MsgBox "Completed" End Sub ' ' ----------------------- ' Sub Write_Index DIM Context Dim DB Dim Conn Dim Stmt Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() Dim jNo As Integer Dim bFile As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" bFile = path & "Index.txt" jNo = Freefile Open bFile For Input As #jNo Do While not eof(jNo) ' read the records Line Input #jNo, CurrentLine 'MsgBox CurrentLine 'MsgBox strValues strings=Split (CurrentLine,",") index = strings(0) id = strings(1) strSQL="UPDATE MEMBERSHIP SET INDEX = "& index &" WHERE ADDKEY = "& id &"" Stmt.executeUpdate(strSQL) Loop Close #jNo End Sub ' ' -------------------------------------------- ' found this in Base forum Sub Defrag_database dim ctx, db, con, stmt ctx = createUnoService("com.sun.star.sdb.DatabaseContext") db = ctx.getByName("U3A_Membership_Database") con = db.getConnection( "", "" ) stmt = con.CreateStatement stmt.ExecuteUpdate( "CHECKPOINT DEFRAG" ) con.dispose MsgBox "Completed" End Sub ' ' ------------------------------------------------------ ' Sub Delete_Contents_Members_Merged Dim Context Dim DB Dim Conn Dim Stmt 'Dim Result ' do not appear to need this Dim strSQL As String Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL="DELETE FROM MEMBERS_MERGED" Stmt.executeUpdate(strSQL) Conn.close() End Sub ' ' ----------- ' this extracts a variety of statistics Sub Stats ' the first three are to renew the Merged Members table Delete_Contents_Members_Merged Extract_Members Merge_Members StatsBody End Sub ' ' ----------------------- ' Sub StatsBody Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim Strng As String Dim strSQL As String Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() ' stats on membership numbers strSQL= "SELECT MEMBERSHIP_TYPE, COUNT(MEMBERSHIP.* ) FROM MEMBERSHIP GROUP BY MEMBERSHIP_TYPE ORDER BY MEMBERSHIP_TYPE ASC" Result=Stmt.executeQuery(strSQL) Strng = "Membership counts sorted by membership type" & chr(13) While Result.next() Membership_type = Result.getString(1) Cnt = Result.getInt(2) Strng = Strng & Membership_type & " " & Cnt & chr(13) Wend Strng = Strng & chr(13) ' stats on gender numbers strSQL= "SELECT SEX, COUNT(MEMBER_NO) FROM MEMBER GROUP BY SEX ORDER BY SEX ASC" Result=Stmt.executeQuery(strSQL) Strng = Strng & chr(13) & "Member count " & chr(13) TotalM = 0 TotalF = 0 While Result.next() Sex = Result.getString(1) Cnt = Result.getInt(2) If Sex = "M" Then TotalM = Cnt else TotalF = Cnt End If Wend Strng = Strng & "Male members " & TotalM & chr(13) & "Female members " & TotalF & chr(13) ' stats on renewals so far and money paid strSQL= "SELECT COUNT(MEMBERSHIP.ADDKEY), GIFT_AID, SUM(SUBSCRIPTION) FROM SUBSCRIPTION, MEMBERSHIP"_ & " WHERE (SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY) GROUP BY GIFT_AID ORDER BY GIFT_AID ASC" Result=Stmt.executeQuery(strSQL) Strng = Strng & chr(13) & "No of renewed/new memberships so far plus money paid and gift aid counts" & chr(13) While Result.next() Gift_aid = Result.getString(2) Cnt = Result.getInt(1) Sum = Result.getInt(3) Strng = Strng & Gift_aid & " " & Cnt & " " & "" & Sum & chr(13) Wend ' stats on non-renewals so far strSQL= "SELECT COUNT(MEMBERSHIP.ADDKEY), COUNT(SUBSCRIPTION.ADDKEY) FROM MEMBERSHIP " _ & " LEFT OUTER JOIN SUBSCRIPTION ON SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY" Result=Stmt.executeQuery(strSQL) Strng = Strng & chr(13) & "No of non renewed memberships so far" & chr(13) While Result.next() Cnt = Result.getInt(1) - Result.getInt(2) Wend Strng = Strng & Cnt & chr(13) ' stats on newsletters strSQL= "SELECT COUNT(MEMBERSHIP.*),NEWS_LETTER FROM MEMBERSHIP GROUP BY NEWS_LETTER ORDER BY NEWS_LETTER ASC" Result=Stmt.executeQuery(strSQL) Strng = Strng & chr(13) & "Newsletter counts" & chr(13) While Result.next() Cnt = Result.getInt(1) Newsletter = Result.getString(2) Strng = Strng & Newsletter & " " & Cnt & chr(13) Wend ' stats on new members this year - this depends on new members having no INDEX - can do better if joining date used strSQL= "SELECT COUNT(MEMBER.*), MEMBERSHIP.INDEX FROM MEMBER, MEMBERSHIP WHERE (MEMBER.ADD_KEY = MEMBERSHIP.ADDKEY) " _ & "GROUP BY MEMBERSHIP.INDEX HAVING ((MEMBERSHIP.INDEX IS NULL))" Result=Stmt.executeQuery(strSQL) While Result.next() Cnt = Result.getInt(1) If Result.getInt(1) <> 0 Then ' there are new members Cnt = Result.getInt(1) else Cnt = 0 End if Strng = Strng & chr(13) & "New members this year " & Cnt & chr(13) Wend Msgbox Strng & chr(13) & "Completed", ,"Statistics" End Sub ' ' ----------- ' Sub Delete_Members_with_Status_of_D Dim Context Dim DB Dim Conn Dim Stmt Dim strSQL As String Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL="DELETE FROM MEMBER WHERE STATUS = 'D'" Stmt.executeUpdate(strSQL) Conn.close() MsgBox "Completed",,"Removing Status D members" End Sub ' ' ----------- ' Sub Macro_test MsgBox "Macro file placed and working" End Sub ' ' ----------- ' Sub Recreate_Merged_Members Delete_Contents_Members_Merged Extract_Members Merge_Members Msgbox "Completed" End Sub ' ' ----------- ' Sub Newsletters_for_all Delete_Contents_Members_Merged Extract_Members Merge_Members Newsletter_A4_distribution Newsletter_A3_distribution Newsletter_Email_distribution Strng1 = "Distribution files have been produced and " Strng2 = "are in Excel format to pass to PrestoPrint" Msgbox Strng1 & chr(13) & Strng2 & chr(13) End sub ' ' ------------------------------------------------------- ' Sub Newsletter_A4_distribution ' this reads one row at a time and will write to a spreadsheet Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim OName As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" urlpath = "file:///C:/Documents%20and%20Settings/Administrator/My%20Documents/U3A_Membership_Database/" 'open a blank spreadsheet - it worked and db read oDesk = createUnoService ("com.sun.star.frame.Desktop") oURL = "private:factory/scalc" oDoc = oDesk.loadComponentFromURL (oURL, "_blank", 0, Array() ) oSheet = oDoc.sheets(0) ' the first sheet ' access the database Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEM1NO, TITLE1, FIRST1,SECOND1, MEM2NO, TITLE2, FIRST2, SECOND2, INDEX, LINE1, LINE2, LINE3," _ & " POST_CODE FROM MEMBERS_MERGED, MEMBERSHIP WHERE (MEMBERS_MERGED.KEY = MEMBERSHIP.ADDKEY AND NEWS_LETTER = 'A4') " _ & " ORDER BY MEMBERSHIP.INDEX ASC" Result=Stmt.executeQuery(strSQL) While Result.next() If Result.getInt(5) = 0 Then OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4) else OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4)_ +" & "+Result.getString(6)+" "+Result.getString(7)+" "+Result.getString(8) End if ' write each record to a new line oCell = oSheet.getCellByPosition (0,i) oCell.Value = Result.getInt(9) 'the index number in first col oCell = oSheet.getCellByPosition (1,i) oCell.String = OName ' the combined name oCell = oSheet.getCellByPosition (2,i) oCell.String = Result.getString(10) ' the next four are the address lines and post code oCell = oSheet.getCellByPosition (3,i) oCell.String = Result.getString(11) oCell = oSheet.getCellByPosition (4,i) oCell.String = Result.getString(12) oCell = oSheet.getCellByPosition (5,i) oCell.String = Result.getString(13) i = i+1 Wend ' save as calc document cFile = path &"A4_Distribution_List" ' Now save the spreadsheet in native OOo Calc format. cURL = ConvertToURL( cFile + ".ods" ) ' saves as a calc document oDoc.storeAsURL( cURL, Array() ) ' save as an Excel spreadsheet dim document as object dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim args1(2) as new com.sun.star.beans.PropertyValue args1(0).Name = "URL" args1(0).Value = urlpath & "A4_Distribution_List.xls" args1(1).Name = "FilterName" args1(1).Value = "MS Excel 97" args1(2).Name = "SelectionOnly" args1(2).Value = true dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1()) End Sub ' ' ------------------------------------------------------------------------------ ' Sub Newsletter_A3_distribution ' this reads one row at a time and will write to a spreadsheet Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim OName As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" urlpath = "file:///C:/Documents%20and%20Settings/Administrator/My%20Documents/U3A_Membership_Database/" 'open a blank spreadsheet - it worked and db read oDesk = createUnoService ("com.sun.star.frame.Desktop") oURL = "private:factory/scalc" oDoc = oDesk.loadComponentFromURL (oURL, "_blank", 0, Array() ) oSheet = oDoc.sheets(0) ' the first sheet ' access the database Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEM1NO, TITLE1, FIRST1,SECOND1, MEM2NO, TITLE2, FIRST2, SECOND2, INDEX, LINE1, LINE2, LINE3, " _ & " POST_CODE FROM MEMBERS_MERGED, MEMBERSHIP WHERE (MEMBERS_MERGED.KEY = MEMBERSHIP.ADDKEY AND NEWS_LETTER = 'A3')" _ & " ORDER BY MEMBERSHIP.INDEX ASC" Result=Stmt.executeQuery(strSQL) While Result.next() If Result.getInt(5) = 0 Then OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4) else OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4)_ +" & "+Result.getString(6)+" "+Result.getString(7)+" "+Result.getString(8) End if ' write each record to a new line oCell = oSheet.getCellByPosition (0,i) oCell.Value = Result.getInt(9) 'the index number in first col oCell = oSheet.getCellByPosition (1,i) oCell.String = OName ' the combined name oCell = oSheet.getCellByPosition (2,i) oCell.String = Result.getString(10) ' the next four are the address lines and post code oCell = oSheet.getCellByPosition (3,i) oCell.String = Result.getString(11) oCell = oSheet.getCellByPosition (4,i) oCell.String = Result.getString(12) oCell = oSheet.getCellByPosition (5,i) oCell.String = Result.getString(13) i = i+1 Wend cFile = path & "A3_Distribution_List" ' Now save the spreadsheet in native OOo Calc format. cURL = ConvertToURL( cFile + ".ods" ) ' saves as a calc document oDoc.storeAsURL( cURL, Array() ) ' save as an Excel spreadsheet dim document as object dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim args1(2) as new com.sun.star.beans.PropertyValue args1(0).Name = "URL" args1(0).Value = urlpath & "A3_Distribution_List.xls" args1(1).Name = "FilterName" args1(1).Value = "MS Excel 97" args1(2).Name = "SelectionOnly" args1(2).Value = true dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1()) End Sub ' ' ------------------------------------------------------------------------------ ' Sub Newsletter_Email_distribution ' this reads one row at a time and will write to a spreadsheet Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim OName As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" 'open a blank spreadsheet - it worked and db read oDesk = createUnoService ("com.sun.star.frame.Desktop") oURL = "private:factory/scalc" oDoc = oDesk.loadComponentFromURL (oURL, "_blank", 0, Array() ) oSheet = oDoc.sheets(0) ' the first sheet ' access the database Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEM1NO, TITLE1, FIRST1,SECOND1, MEM2NO, TITLE2, FIRST2, SECOND2, EMAIL FROM MEMBERS_MERGED, " _ & " MEMBERSHIP WHERE (MEMBERS_MERGED.KEY = MEMBERSHIP.ADDKEY AND NEWS_LETTER = 'E') ORDER BY MEMBERSHIP.INDEX ASC" Result=Stmt.executeQuery(strSQL) While Result.next() If Result.getInt(5) = 0 Then ' does second memebr exist for that membership ' I am surprised - the macro treats an integer field which is null as zero OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4) else OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4)_ +" & "+Result.getString(6)+" "+Result.getString(7)+" "+Result.getString(8) End if ' write each record to a new line oCell = oSheet.getCellByPosition (0,i) oCell.String = OName ' the combined name oCell = oSheet.getCellByPosition (1,i) oCell.String = Result.getString(9) ' email address i = i+1 Wend cFile = path & "Email_Distribution_List" ' to save in ' Now save the spreadsheet in native OOo Calc format. cURL = ConvertToURL( cFile + ".ods" ) ' saves as a calc document oDoc.storeAsURL( cURL, Array() ) End Sub ' ' ------------------------------------------------------------------------------ ' Sub Newsletters_for_Renewals Delete_Contents_Members_Merged Extract_Members Merge_Members A4_Renewals_Only A3_Renewals_Only Email_Renewals_Only Strng1 = "Distribution files have been produced and " Strng2 = "are in Excel format to pass to PrestoPrint" Msgbox Strng1 & chr(13) & Strng2 & chr(13) End Sub ' ' ----------------------- ' Sub A4_Renewals_Only ' this is for newsletters for renewals only and it worked ' this reads one row at a time and will write to a spreadsheet Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim OName As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" urlpath = "file:///C:/Documents%20and%20Settings/Administrator/My%20Documents/U3A_Membership_Database/" 'open a blank spreadsheet - it worked and db read oDesk = createUnoService ("com.sun.star.frame.Desktop") oURL = "private:factory/scalc" oDoc = oDesk.loadComponentFromURL (oURL, "_blank", 0, Array() ) oSheet = oDoc.sheets(0) ' the first sheet ' access the database Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEM1NO, TITLE1, FIRST1,SECOND1, MEM2NO, TITLE2, FIRST2, SECOND2, LINE1, LINE2, LINE3, POST_CODE," _ & " NEWS_LETTER FROM SUBSCRIPTION, MEMBERSHIP, MEMBERS_MERGED WHERE (SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY AND " _ & " MEMBERS_MERGED.KEY = MEMBERSHIP.ADDKEY AND MEMBERSHIP.NEWS_LETTER = 'A4' ) ORDER BY MEMBERS_MERGED.SECOND1 ASC" Result=Stmt.executeQuery(strSQL) While Result.next() If Result.getInt(5) = 0 Then ' I am surprised - the macro treats an integer field which is null as zero OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4) else OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4)_ +" & "+Result.getString(6)+" "+Result.getString(7)+" "+Result.getString(8) End if ' write each record to a new line 'oCell = oSheet.getCellByPosition (0,i) 'oCell.Value = Result.getInt(9) 'the index number in first col oCell = oSheet.getCellByPosition (1,i) oCell.String = OName ' the combined name oCell = oSheet.getCellByPosition (2,i) oCell.String = Result.getString(9) ' the next four are the address lines and post code oCell = oSheet.getCellByPosition (3,i) oCell.String = Result.getString(10) oCell = oSheet.getCellByPosition (4,i) oCell.String = Result.getString(11) oCell = oSheet.getCellByPosition (5,i) oCell.String = Result.getString(12) i = i+1 Wend ' save as calc document cFile = path & "A4_Distribution_List" cURL = ConvertToURL( cFile + ".ods" ) oDoc.storeAsURL( cURL, Array() ) ' save as an Excel spreadsheet dim document as object dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim args1(2) as new com.sun.star.beans.PropertyValue args1(0).Name = "URL" args1(0).Value = urlpath & "A4_Distribution_List.xls" args1(1).Name = "FilterName" args1(1).Value = "MS Excel 97" args1(2).Name = "SelectionOnly" args1(2).Value = true dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1()) End Sub ' ' ----------------------- ' Sub A3_Renewals_Only ' this is for newsletters for renewals only and it worked ' this reads one row at a time and will write to a spreadsheet Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim OName As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" urlpath = "file:///C:/Documents%20and%20Settings/Administrator/My%20Documents/U3A_Membership_Database/" 'open a blank spreadsheet - it worked and db read oDesk = createUnoService ("com.sun.star.frame.Desktop") oURL = "private:factory/scalc" oDoc = oDesk.loadComponentFromURL (oURL, "_blank", 0, Array() ) oSheet = oDoc.sheets(0) ' the first sheet ' access the database Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEM1NO, TITLE1, FIRST1,SECOND1, MEM2NO, TITLE2, FIRST2, SECOND2, LINE1, LINE2, LINE3, POST_CODE, " _ & " NEWS_LETTER FROM SUBSCRIPTION, MEMBERSHIP, MEMBERS_MERGED WHERE (SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY AND " _ & " MEMBERS_MERGED.KEY = MEMBERSHIP.ADDKEY AND MEMBERSHIP.NEWS_LETTER = 'A3' ) ORDER BY MEMBERS_MERGED.SECOND1 ASC" Result=Stmt.executeQuery(strSQL) While Result.next() If Result.getInt(5) = 0 Then ' I am surprised - the macro treats an integer field which is null as zero OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4) else OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4)_ +" & "+Result.getString(6)+" "+Result.getString(7)+" "+Result.getString(8) End if ' write each record to a new line 'oCell = oSheet.getCellByPosition (0,i) 'oCell.Value = Result.getInt(9) 'the index number in first col oCell = oSheet.getCellByPosition (1,i) oCell.String = OName ' the combined name oCell = oSheet.getCellByPosition (2,i) oCell.String = Result.getString(9) ' the next four are the address lines and post code oCell = oSheet.getCellByPosition (3,i) oCell.String = Result.getString(10) oCell = oSheet.getCellByPosition (4,i) oCell.String = Result.getString(11) oCell = oSheet.getCellByPosition (5,i) oCell.String = Result.getString(12) i = i+1 Wend ' save as calc document cFile = path & "A3_Distribution_List" cURL = ConvertToURL( cFile + ".ods" ) oDoc.storeAsURL( cURL, Array() ) ' save as an Excel spreadsheet dim document as object dim dispatcher as object document = ThisComponent.CurrentController.Frame dispatcher = createUnoService("com.sun.star.frame.DispatchHelper") dim args1(2) as new com.sun.star.beans.PropertyValue args1(0).Name = "URL" args1(0).Value = urlpath & "A3_Distribution_List.xls" args1(1).Name = "FilterName" args1(1).Value = "MS Excel 97" args1(2).Name = "SelectionOnly" args1(2).Value = true dispatcher.executeDispatch(document, ".uno:SaveAs", "", 0, args1()) End Sub ' ' ----------------------- ' Sub Email_Renewals_Only ' this is for newsletters for renewals only and it worked ' this reads one row at a time and will write to a spreadsheet Dim Context Dim DB Dim Conn Dim Stmt Dim Result Dim strSQL As String Dim OName As String path = "C:\Documents and Settings\Administrator\My Documents\U3A_Membership_Database\" 'open a blank spreadsheet - it worked and db read oDesk = createUnoService ("com.sun.star.frame.Desktop") oURL = "private:factory/scalc" oDoc = oDesk.loadComponentFromURL (oURL, "_blank", 0, Array() ) oSheet = oDoc.sheets(0) ' the first sheet ' access the database Context=CreateUnoService("com.sun.star.sdb.DatabaseContext") DB=Context.getByName("U3A_Membership_Database") Conn=DB.getConnection("","") Stmt=Conn.createStatement() strSQL= "SELECT MEM1NO, TITLE1, FIRST1,SECOND1, MEM2NO, TITLE2, FIRST2, SECOND2, EMAIL FROM SUBSCRIPTION, " _ & " MEMBERSHIP, MEMBERS_MERGED WHERE (SUBSCRIPTION.ADDKEY = MEMBERSHIP.ADDKEY AND MEMBERS_MERGED.KEY = MEMBERSHIP.ADDKEY " _ & " AND MEMBERSHIP.NEWS_LETTER = 'E' ) ORDER BY MEMBERS_MERGED.SECOND1 ASC" Result=Stmt.executeQuery(strSQL) While Result.next() If Result.getInt(5) = 0 Then ' I am surprised - the macro treats an integer field which is null as zero OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4) else OName = Result.getString(2)+" "+Result.getString(3)+" "+Result.getString(4)_ +" & "+Result.getString(6)+" "+Result.getString(7)+" "+Result.getString(8) End if ' write each record to a new line oCell = oSheet.getCellByPosition (0,i) oCell.String = OName ' the combined name oCell = oSheet.getCellByPosition (1,i) oCell.String = Result.getString(9) i = i+1 Wend ' save as calc document cFile = path & "Email_Distribution_List" cURL = ConvertToURL( cFile + ".ods" ) oDoc.storeAsURL( cURL, Array() ) End Sub ' ' ----------------------- ' Sub SearchByIndex dim oFilter as object dim oFormCtl as object dim Intg As Integer oFormCtl = ThisComponent.Drawpage.Forms.getByName("MainForm") oFilter = oFormCtl.getByName("TextBox") if oFilter.Text <> "" then Intg = oFilter.Text oFormCtl.Filter = "INDEX = "& Intg &"" oFormCtl.ApplyFilter = True else oFormCtl.ApplyFilter = False end if oFormCtl.Reload End sub ' Sub SearchByAddressKey dim oFilter as object dim oFormCtl as object dim Intg As Integer oFormCtl = ThisComponent.Drawpage.Forms.getByName("MainForm") oFilter = oFormCtl.getByName("TextBox1") if oFilter.Text <> "" then Intg = oFilter.Text oFormCtl.Filter = "ADDKEY = "& Intg &"" oFormCtl.ApplyFilter = True else oFormCtl.ApplyFilter = False end if oFormCtl.Reload End Sub ' Sub SearchByMembershipNo ' to filter on an integer field dim oFilter as object dim oFormCtl as object dim Intg As Integer oFormCtl = ThisComponent.Drawpage.Forms.getByName("MainForm") oFilter = oFormCtl.getByName("TextBox") if oFilter.Text <> "" then Intg = oFilter.Text oFormCtl.Filter = "MEMBER_NO = "& Intg &"" 'MsgBox oFormCtl.Filter oFormCtl.ApplyFilter = True else oFormCtl.ApplyFilter = False end if oFormCtl.Reload End Sub ' ' ------------------------------------------------------------ ' I found this group in the Base forum - it will open a form full screen ' event is on loading ' NB - this does not work in Ubuntu sub onWhenLoading( oEvent as object ) MaximizeFrame( oEvent.Source.Parent.Parent.CurrentController.Frame) end sub Declare Function ShowWindow Lib "user32" (ByVal lHwnd As Long, ByVal lCmdShow As Long) As Boolean sub MaximizeFrame( aFrame as object ) dim frame dim window dim handle window = aframe.getContainerWindow() handle = window.getWindowHandle(dimarray(), 1) REM 1=WIN32 ShowWindow( handle, 3 ) end sub ' ' ------------------------------------------------------------ '