1 Option Compare Database 2 Option Explicit 3 ' 4 ' code behind f_ADMIN 5 ' 6 '============================================================ LICENSE NOTICE -- must not be modified 7 ' This software is licensed to you under CC BY-NC-SA 3.0 8 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 9 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 10 ' 11 ' You are free to: 12 ' Share — copy and redistribute the material in any medium or format 13 ' Adapt — remix, transform, and build upon the material 14 ' The licensor cannot revoke these freedoms as long as you follow these terms: 15 ' Attribution — You must give appropriate credit, provide a link to the license, 16 ' and indicate if changes were made. 17 ' You may do so in any reasonable manner, 18 ' but not in any way that suggests the licensor endorses you or your use. 19 ' NonCommercial — You may not use the material for commercial purposes. 20 ' ShareAlike — If you remix, transform, or build upon the material, 21 ' you must distribute your contributions under the same license as the original. 22 ' 23 ' many procedures and module names contain author or controbitor names that must be left intact 24 ' if you make changes, add your name, date, and descriptive information to the comments 25 ' 26 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 27 ' ~ Crystal 28 ' * have an awesome day :) 29 ' www.AccessMVP.com/strive4peace 30 ' END LICENSE NOTICE 31 '============================================================ 32 ' 33 ' NEEDS 34 ' bas_Crystal_ReLinker_97-2013_131112 35 ' mod_crystal_GetFile_Browse 36 37 Dim booRelinkerRunning As Boolean |
38 39 Private Sub cmd_DeleteData_Click() 40 '141005 41 Call DeleteRecords 42 End Sub |
43 44 Public Sub Form_Open(Cancel As Integer) 45 '110918, 1110, 1125, 140928, 141014 booRelinkerRunning 46 47 ' CALLS 48 ' SetBackColor 49 ' READS 50 ' property: local_UsrID 51 ' table: c_Usrs 52 53 'Stop 54 55 Call pri_UsrMgt_SetProperties 56 'see if connection is ok 57 'if it is, cancel loading this form 58 ' If IsBEok("c_KeepOpen") Then ', True) Then 'open BE and keep table open 59 ' If IsBEok("c_Contact") Then ', True) Then 'open BE and keep table open 60 ' If Len(Nz(Me.OpenArgs, "")) > 0 Then GoTo LoadData 61 ' 'CANCEL THE FORM 62 ' Cancel = True 63 ' 'open Contacts form 64 ' DoCmd.OpenForm "fc_MENU_CONTACT" 65 ' Exit Sub 66 ' End If 67 '------------------------------------------ 68 'Private Sub Form_Load() 69 LoadData: 70 Dim nUsrID As Long _ 71 , nUsrCatID As Long _ 72 , sPath As String _ 73 , nNum As Long _ 74 , sSQL As String 75 76 Dim db As DAO.Database _ 77 , rs As DAO.Recordset 78 79 Dim boo As Boolean 80 81 nUsrID = Get_Property("local_UsrID") 82 nNum = Nz(DLookup("UsrID", "c_Usrs", "UsrID=" & nUsrID), -99) 83 84 If nNum < 0 Then 85 User_Not_Found: 86 'user not found -- read properties 87 nUsrCatID = Get_Property("local_UsrCatID") 88 If nUsrCatID > 0 Then 89 Me.usrCatID = nUsrCatID 90 End If 91 92 sPath = Get_Property("local_PathBE") 93 If Len(Trim(sPath)) > 0 Then 94 Me.PathBE = sPath 95 End If 96 Call SetBackColor("BE", sPath) 97 98 Me.PathBE.BackColor = RGB(255, 0, 0) 99 100 With Me.PathAtt 101 If .Visible = True Then 102 sPath = Get_Property("local_PathAtt") 103 If Len(Trim(sPath)) > 0 Then 104 .Value = sPath 105 End If 106 Call SetBackColor("Att", sPath) 107 End If 108 End With 'PathAtt 109 110 With Me.Path1 111 If .Visible = True Then 112 sPath = Get_Property("local_Path1") 113 If Len(Trim(sPath)) > 0 Then 114 .Value = sPath 115 End If 116 Call SetBackColor("Tpl", sPath) 117 End If 118 End With 'Path1 119 'DONE FILLING INFORMATION -- Exit Sub 120 Exit Sub 121 End If 'got information from properties 122 123 Me.UsrID = nUsrID 124 125 ' read User settings from c_Usrs table 126 127 Set db = CurrentDb 128 sSQL = "SELECT c_Usrs.* " _ 129 & " FROM c_Usrs " _ 130 & " WHERE UsrID = " & nUsrID _ 131 & ";" 132 Set rs = db.OpenRecordset(sSQL, dbOpenSnapshot) 133 With rs 134 If .EOF Then 135 'user not found in table 136 GoTo User_Not_Found 137 End If 138 139 If Not IsNull(!usrCatID) Then 140 Me.usrCatID = !usrCatID 141 End If 142 If Not IsNull(!PathBE) Then 143 sPath = !PathBE 144 Me.PathBE = sPath 145 Else 146 sPath = "" 147 End If 148 Call SetBackColor("BE", sPath) 149 150 If Me.PathAtt.Visible = True Then 151 If Not IsNull(!PathAtt) Then 152 sPath = !PathAtt 153 Me.PathAtt = sPath 154 Else 155 sPath = "" 156 End If 157 Call SetBackColor("Att", sPath) 158 End If 159 160 If Me.Path1.Visible = True Then 161 If Not IsNull(!Path1) Then 162 sPath = !Path1 163 Me.Path1 = sPath 164 Else 165 sPath = "" 166 End If 167 Call SetBackColor("Tpl", sPath) 168 End If 169 End With 'rs 170 171 Proc_Exit: 172 On Error Resume Next 173 booRelinkerRunning = False 174 'release object variables 175 If Not rs Is Nothing Then 176 rs.Close 177 Set rs = Nothing 178 End If 179 If Not db Is Nothing Then Set db = Nothing 180 Exit Sub 181 182 Proc_Err: 183 MsgBox Err.Description, , _ 184 "ERROR " & Err.Number _ 185 & " Form_Load : " & Me.Name 186 187 Resume Proc_Exit 188 Resume 189 End Sub |
190 191 Private Sub cmd_Browse_PathBE_Click() 192 '140102 193 Call SetDirectory("BE", Nz(Me.PathBE, ""), Me.PathBE) 194 End Sub 195 196 'needs tables: 197 ' c_Usrs 198 ' c_UsrCats 199 200 'properties: 201 ' local_IsAdmin 202 ' local_UsrID 203 ' local_UsrCatID 204 ' local_UsrName 205 ' local_PathBE 206 ' local_PathAtt 207 ' local_Path1 208 ' local_Password 209 210 'local procedures that could be in a standard module: 211 ' pri_UsrMgt_SetProperties 212 ' pri_DropMe 213 214 'Private Sub Form_Open(Cancel As Integer) 215 ''110918, 1110 216 ' 'CALLS 217 ' ' pri_UsrMgt_SetProperties 218 ' ' Get_Property 219 ' 220 ' 'set database properties 221 ' Call pri_UsrMgt_SetProperties 222 ' On Error Resume Next 223 ' DoCmd.OpenForm "usys_fP", , , , , acDialog 224 ' If Get_Property("local_Password") <> "secret" Then 225 ' Cancel = True 226 ' 'MsgBox "You do not have permission to open this form" _ 227 ' , , "canceling open form" 228 ' End If 229 ' 230 'End Sub |
231 232 233 234 Private Sub cmd_NavigationPane_Click() 235 '131107 236 DoCmd.SelectObject acTable, "c_Contact", True 237 End Sub |
238 239 Private Sub cmd_SaveClose_Click() 240 '121125, 141014 iNumChanges, booRelinkerRunning 241 On Error GoTo Proc_Err 242 243 Dim nUsrID As Long _ 244 , nUsrCatID As Long _ 245 , sUsrName As String _ 246 , sPath As String _ 247 , iNumChanges As Integer 248 249 iNumChanges = 0 250 251 If booRelinkerRunning Then 252 MsgBox "Wait until the Relinker is done", , "Can't save yet" 253 GoTo Proc_Exit 254 End If 255 256 With Me.UsrID 257 If IsNull(.Value) Then 258 .SetFocus 259 MsgBox "Please choose a user", , "Cannot Save" 260 GoTo Proc_Exit 261 Else 262 If IsNull(Me.usrCatID) Then 263 Me.usrCatID.SetFocus 264 If MsgBox("Do you want to set user priviges before saving?" _ 265 , vbYesNo + vbDefaultButton2 _ 266 , "User Category isn't set -- Save anyway?") = vbNo Then Exit Sub 267 Me.usrCatID.Dropdown 268 GoTo Proc_Exit 269 End If 270 If IsNull(Me.PathBE) Then 271 MsgBox "Please choose Back End Path", , "Cannot Save" 272 GoTo Proc_Exit 273 End If 274 nUsrID = Get_Property("local_UsrID") 275 If nUsrID <> .Value Then 276 iNumChanges = iNumChanges + 1 277 nUsrID = Me.UsrID 278 Call Set_Property("local_usrID", nUsrID) 279 280 sUsrName = Me.UsrID.Column(1) 281 If Not Len(sUsrName) > 0 Then 282 sUsrName = " " 283 End If 284 Call Set_Property("local_UsrName", sUsrName) 285 End If 286 287 End If 288 End With 289 290 With Me.usrCatID 291 If IsNull(.Value) Then 292 nUsrCatID = -99 293 Else 294 nUsrCatID = Get_Property("local_UsrCatID") 295 End If 296 If nUsrCatID <> .Value Then 297 iNumChanges = iNumChanges + 1 298 nUsrCatID = .Value 299 Call Set_Property("local_UsrCatID", nUsrCatID) 300 End If 301 End With 302 303 sPath = Get_Property("local_PathBE") 304 With Me.PathBE 305 If sPath <> .Value Then 306 iNumChanges = iNumChanges + 1 307 sPath = .Value 308 Call Set_Property("local_PathBE", sPath) 309 End If 310 End With 311 312 With Me.PathAtt 313 If .Visible Then 314 sPath = Get_Property("local_PathAtt") 315 If sPath <> .Value Then 316 iNumChanges = iNumChanges + 1 317 sPath = .Value 318 Call Set_Property("local_PathAtt", sPath) 319 End If 320 End If 321 End With 322 323 With Me.Path1 324 If .Visible Then 325 sPath = Get_Property("local_Path1") 326 If sPath <> .Value Then 327 iNumChanges = iNumChanges + 1 328 sPath = .Value 329 Call Set_Property("local_Path1", sPath) 330 End If 331 End If 332 End With 333 334 'open Contacts form 335 DoCmd.OpenForm "fc_MENU_CONTACT" 336 MsgBox "Saved " & iNumChanges & " changed values for user setup", , "Done" 337 DoCmd.Close acForm, Me.Name, acSaveNo 338 339 Proc_Exit: 340 On Error Resume Next 341 Exit Sub 342 343 Proc_Err: 344 MsgBox Err.Description, , _ 345 "ERROR " & Err.Number _ 346 & " cmd_SaveClose_Click : " & Me.Name 347 348 Resume Proc_Exit 349 Resume 350 End Sub |
351 352 Private Sub cmd_Cancel_Click() 353 '110519, 121125 354 DoCmd.Close acForm, Me.Name, acSaveNo 355 End Sub |
356 357 358 359 Private Sub usrCatID_AfterUpdate() 360 '131110 361 If IsNull(Me.UsrID) Then Exit Sub 362 Dim nUsrID As Long _ 363 , nUsrCatID As Long _ 364 , sSQL As String 365 nUsrID = Me.UsrID 366 sSQL = "UPDATE c_Usrs SET UsrCatID = " 367 With Me.usrCatID 368 If IsNull(.Value) Then 369 nUsrCatID = -1 370 sSQL = sSQL & " null " 371 Else 372 nUsrCatID = .Value 373 sSQL = sSQL & nUsrCatID 374 End If 375 End With 376 sSQL = sSQL & " WHERE UsrID=" & nUsrID 377 Call rSql(sSQL) 378 379 Call Set_Property("local_UsrCatID", nUsrCatID) 380 381 Me.UsrID.Requery 382 End Sub |
383 384 Private Sub UsrID_AfterUpdate() 385 '131110, 140210 386 'change the default user 387 'CALLS 388 ' Set_Property 389 390 '0. UsrID 391 '1. UsrName 392 '2. usrCat 393 '3. PathBE 394 '4. PathAtt 395 '5. Path1 396 '6. usrCatID 397 398 Dim nUsrID As Long _ 399 , nUsrCatID As Long _ 400 , sUserName As String _ 401 , sPath As String _ 402 , sMsg As String _ 403 , sSQL As String 404 405 With Me.UsrID 406 nUsrID = .Value 407 ' If .Column(1) <> .Text Then 408 ' MsgBox "text changed" 409 ' sMsg = "Do you want to CHANGE current username to '" _ 410 ' & Replace(.Text, "'", "''") & "'" & "? " 411 ' If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CHANGE User Name?") = vbYes Then 412 ' sSQL = "UPDATE c_Usrs " _ 413 ' & " SET UsrName = '" & Replace(.Text, "'", "''") & "'" _ 414 ' & " WHERE UsrID=" & nUsrID _ 415 ' & ";" 416 ' Call rSql(sSQL) 417 ' Me.UsrID.Requery 418 ' End If 419 ' End If 420 ' 421 ' If nUsrID = Nz(.OldValue) Then Exit Sub 422 Set_Property "local_UsrID", nUsrID 423 424 If .Column(6) <> "" Then 425 nUsrCatID = .Column(6) 426 Me.usrCatID = nUsrCatID 427 Else 428 Me.usrCatID = Null 429 End If 430 431 If UsrID.Column(3) <> "" Then 432 sPath = Nz(.Column(3), " ") 433 If Len(Trim(sPath)) > 0 Then 434 Me.PathBE = sPath 435 'link to tables 436 Call ReLinker(sPath) 437 Else 438 Me.PathBE = Null 439 End If 440 Else 441 sPath = "" 442 Me.PathBE = Null 443 End If 444 Call SetBackColor("BE", sPath) 445 446 'Attachment directory 447 If Me.PathAtt.Visible = True Then 448 If UsrID.Column(4) <> "" Then 449 sPath = Nz(.Column(4), " ") 450 If Len(Trim(sPath)) > 0 Then 451 Me.PathAtt = sPath 452 Else 453 Me.PathAtt = Null 454 End If 455 Else 456 sPath = "" 457 Me.PathAtt = Null 458 End If 459 Call SetBackColor("Att", sPath) 460 End If 461 'Template directory 462 If Me.Path1.Visible = True Then 463 If UsrID.Column(5) <> "" Then 464 sPath = Nz(.Column(5), " ") 465 If Len(Trim(sPath)) > 0 Then 466 Me.Path1 = sPath 467 Else 468 Me.Path1 = Null 469 End If 470 Me.Path1 = sPath 471 Else 472 sPath = "" 473 Me.Path1 = Null 474 Set_Property "local_Path1", " " 475 End If 476 Call SetBackColor("Tpl", sPath) 477 End If 478 End With 'Me.UsrID 479 480 481 End Sub |
482 483 Private Sub UsrID_BeforeUpdate(Cancel As Integer) 484 '110918 485 If IsNull(Me.ActiveControl) Then 486 MsgBox "you are not allowed to leave the User blank", , "Invalid choice" 487 Cancel = True 488 End If 489 End Sub |
490 491 '_____________________________ 492 Private Function pri_DropMe() 493 '131107 494 Me.ActiveControl.Dropdown 495 End Function |
496 497 498 '_____________________________ 499 500 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ NOT IN LIST 501 Private Sub UsrID_NotInList( _ 502 NewData As String _ 503 , Response As Integer) 504 '131110, 25 strive4peace 505 506 'add new user or modify existing user name 507 508 'CALLS 509 ' UsrID_AfterUpdate 510 511 'set up Error Handler 512 On Error GoTo Proc_Err 513 514 Dim sSQL As String _ 515 , sMsg As String _ 516 , nUsrID As Long _ 517 , sNewData As String 518 519 sNewData = Trim(NewData) 520 521 If sNewData = Trim(Me.UsrID.Text) Then 522 'nothing changed 523 Me.Undo 524 Response = acDataErrContinue 525 Exit Sub 526 End If 527 528 ' Display message box asking if user wants to add a new item 529 sMsg = "Do you want to add '" & Replace(sNewData, "'", "''") & "'" & "? " _ 530 531 ' if you want the default to be NO instead of Yes, 532 ' substitute --> vbYesNo + vbDefaultButton2 533 534 If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "ADD New User?") = vbNo Then 535 nUsrID = Get_Property("local_UsrID") 536 If nUsrID > 0 Then 537 sMsg = "Do you want to CHANGE current username to '" _ 538 & Replace(sNewData, "'", "''") & "'" & "? " 539 If MsgBox(sMsg, vbYesNo + vbDefaultButton2, "CHANGE User Name?") = vbYes Then 540 sSQL = "UPDATE c_Usrs " _ 541 & " SET UsrName = '" & Replace(sNewData, "'", "''") & "'" _ 542 & " WHERE UsrID=" & nUsrID _ 543 & ";" 544 Call rSql(sSQL) 545 ' Me.UsrID.Requery 546 Response = acDataErrContinue 547 Else 548 MsgBox "Default User not found", , "Cannot modify" 549 Me.UsrID.Undo 550 Response = acDataErrContinue 551 End If 552 Exit Sub 553 End If 554 555 Me.UsrID.Undo 556 Response = acDataErrContinue 557 Exit Sub 558 End If 559 560 nUsrID = Nz(DMax("UsrID", "c_Usrs"), 1) + 1 561 562 sSQL = "INSERT INTO c_Usrs (UsrID, UsrName) " _ 563 & " SELECT " _ 564 & ", " & nUsrID _ 565 & ", '" & Replace(sNewData, "'", "''") & "'" _ 566 & ";" 567 Call rSql(sSQL) 568 Me.UsrID = nUsrID 569 570 Response = acDataErrAdded 571 572 'set database properties 573 Call UsrID_AfterUpdate 574 575 Proc_Exit: 576 On Error Resume Next 577 Exit Sub 578 579 Proc_Err: 580 MsgBox Err.Description, , _ 581 "ERROR " & Err.Number _ 582 & " NotInList_Aircraft" 583 584 Resume Proc_Exit 585 586 'if you want to single-step code to find error, CTRL-Break at MsgBox 587 'then set this to be the next statement 588 Resume 589 End Sub |
590 591 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ BROWSE 592 Private Function SetDirectory(psWhich As String _ 593 , Optional psPath As Variant = "" _ 594 , Optional ctl As Control _ 595 ) As Byte 596 'strive4peace ... 131125, 141014 597 598 'PARAMETERS 599 ' psWhich = BE, Att, Tpl ... whatever fields/controls/properties you are using 600 ' 601 'TITLE is the CAPTION property of the associated label 602 '( or the control Tag) 603 604 'CALLS 605 ' rSql 606 ' ReLinker 607 608 'note: 609 'passed path is not checked 610 611 On Error GoTo Proc_Err 612 613 booRelinkerRunning = True 614 Dim sFieldname As String _ 615 , sStartPath As String _ 616 , sPath As String _ 617 , vTitle As Variant _ 618 , sSQL As String 619 620 psPath = CStr(psPath) 621 622 sStartPath = "" 623 vTitle = Null 624 625 sFieldname = "Path" & psWhich 626 627 With Me(sFieldname) 628 If Len(Trim(psPath)) > 0 Then 629 'have path 630 sStartPath = GetGoodPartOfPath(psPath) 631 Else 632 'path not specified -- get from control 633 If Not IsNull(.Value) Then sStartPath = GetGoodPartOfPath(.Value) 634 End If 635 If .Controls.Count > 0 Then 636 vTitle = .Controls(0).Caption 637 Else 638 If Not IsNull(.Tag) Then vTitle = .Tag 639 End If 640 End With 641 642 sPath = Get_DirectoryDialog(vTitle, sStartPath) 643 If sPath = "" Then 644 'user canceled 645 'no change 646 Exit Function 647 End If 648 649 'see if path has something 650 If Len(Trim(sPath)) > 0 Then 651 'see if path is good 652 If Not Len(Dir(sPath, vbDirectory)) > 0 Then 653 sPath = GetGoodPartOfPath(sPath) 654 If Not Len(sPath) > 2 Then 655 sPath = Get_DirectoryDialog("Directory for " & psWhich, sPath) 656 If sPath = "" Then 657 'cancel 658 Exit Function 659 End If 660 End If 661 End If 662 If Not Len(Trim(sPath)) > 0 Then 663 GoTo Proc_Exit 664 End If 665 With Me(sFieldname) 666 .Value = sPath 667 End With 668 sSQL = "UPDATE c_Usrs " _ 669 & " SET " & sFieldname & " = '" & Replace(sPath, "'", "''") & "'" _ 670 & " WHERE UsrID=" & Me.UsrID _ 671 & ";" 672 673 Call rSql(sSQL) 674 Me.UsrID.Requery 675 If psWhich = "BE" Then 676 'link to tables 677 Call ReLinker(sPath) 678 End If 679 End If 680 681 ColorTheControl: 682 Call SetBackColor(psWhich, sPath) 683 684 Proc_Exit: 685 On Error Resume Next 686 booRelinkerRunning = False 687 Exit Function 688 689 Proc_Err: 690 MsgBox Err.Description, , _ 691 "ERROR " & Err.Number _ 692 & " SetDirectory : " & Me.Name 693 Resume Proc_Exit 694 Resume 695 End Function |
696 697 698 699 Private Sub cmd_OpenUsers_Click() 700 '131110, 141008 701 DoCmd.OpenTable "c_Usrs" 702 MsgBox "If you edit the user category (privileges) while the Admin form is open, " _ 703 & " pick another user on the Admin form and then pick the users whose settings were changed " _ 704 & " to ensure the changes are read correctly." _ 705 & vbCrLf & vbCrLf & "It is better to change the User Category using the Admin form." _ 706 , , "NOTE: Table Edits may be ignored by the Admin form until it is re-opened" 707 End Sub |
708 709 Private Sub cmd_Relink_Click() 710 '131125 711 Dim sPath As String 712 With Me.PathBE 713 If IsNull(.Value) Then 714 'Current Project Path will be used to relink 715 sPath = CurrentProject.Path 716 Exit Sub 717 End If 718 sPath = .Value 719 'link to tables 720 End With 721 booRelinkerRunning = True 722 Call ReLinker(sPath) 723 booRelinkerRunning = False 724 End Sub |
725 726 Private Sub cmdExit_Click() ' ------------ NOT USED 727 '110519 728 Application.Quit 729 End Sub |
730 731 '_________________________________________________ PROPERTIES 732 733 Private Sub pri_UsrMgt_SetProperties( _ 734 Optional bSkipMsg As Boolean = True _ 735 ) 736 '131107, 1110 737 738 ' PARAMETERS 739 ' bSkipMsg = True: skip user intereraction 740 741 ' CALLS 742 ' IsPropertyDefined 743 ' Set_Property 744 745 746 On Error GoTo Proc_Err 747 748 Dim i As Integer _ 749 , sPropName As String _ 750 , nPropType As Long _ 751 , varValue As Variant 752 753 Dim db As DAO.Database 754 755 Set db = CurrentDb 756 757 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ set properties 758 759 For i = 1 To 9 760 761 Select Case i 762 763 Case 1 764 sPropName = "local_IsAdmin" 765 nPropType = dbBoolean 766 varValue = True 767 768 Case 2 769 sPropName = "local_UsrID" 770 nPropType = dbLong 771 varValue = -1 772 773 Case 3 774 sPropName = "local_UsrCatID" 775 nPropType = dbLong 776 varValue = -1 777 778 Case 4 779 sPropName = "local_UsrName" 780 nPropType = dbText 781 varValue = " " 782 783 Case 5 784 sPropName = "local_PathBE" 785 nPropType = dbText 786 varValue = " " 787 788 Case 6 789 sPropName = "local_PathAtt" 790 nPropType = dbText 791 varValue = " " 792 793 Case 7 794 sPropName = "local_Path1" 795 nPropType = dbText 796 varValue = " " 797 798 Case 8 799 sPropName = "local_Password" 800 nPropType = dbText 801 varValue = " " 802 803 Case 9 804 sPropName = "local_AdminMode" 805 nPropType = dbBoolean 806 varValue = False 807 808 End Select 809 810 If Not IsPropertyDefined(sPropName, db) Then 811 Call Set_Property(sPropName, varValue, nPropType, db, bSkipMsg) 812 End If 813 814 Next i 815 816 817 If Not bSkipMsg Then 818 MsgBox "Default Database Properties are set", , "Done" 819 End If 820 821 Proc_Exit: 822 Exit Sub 823 824 Proc_Err: 825 MsgBox Err.Description, , _ 826 "ERROR " & Err.Number _ 827 & " pri_UsrMgt_SetProperties" 828 829 Resume Proc_Exit 830 831 'if you want to single-step code to find error, CTRL-Break at MsgBox 832 'then set this to be the next statement 833 Resume 834 End Sub |
835 836 Private Function SetBackColor(psWhich As String _ 837 , psPath As String _ 838 , Optional ctlnameEnable As String = "" _ 839 ) As Byte 840 '131125 841 'CALLS 842 ' Get_ColorDirectory 843 844 Dim sControlname As String 845 846 sControlname = "Path" & psWhich 847 848 With Me(sControlname) 849 'MsgBox .Value 850 .BackColor = Get_ColorDirectory(psWhich, psPath, Me, sControlname, , "cmd_SaveClose") 851 ' .BackColor = RGB(255, 0, 0) 852 End With 853 End Function |
854 855 Public Function Get_ColorDirectory(psWhich As String _ 856 , Optional pvPath As Variant = "" _ 857 , Optional frm As Form _ 858 , Optional ctlname As String = "" _ 859 , Optional pIsPath As Boolean = True _ 860 , Optional ctlnameEnable As String = "" _ 861 ) As Long 862 '131114, 15, 25, 141014 booEnable 863 864 Dim nDirAttrib As Integer _ 865 , sControlTipText As String _ 866 , booEnable As Variant 867 868 sControlTipText = "" 869 booEnable = False 870 871 If IsNull(pvPath) Then 872 pvPath = "" 873 End If 874 875 If Not Len(Trim(pvPath)) > 1 Then 876 'path not specified (enough) 877 Get_ColorDirectory = RGB(255, 255, 200) 'yellow 878 sControlTipText = "Path not specified" 879 GoTo Proc_Exit 880 End If 881 882 If InStr(pvPath, ".") = 0 And Len(Trim(pvPath)) > 1 Then 883 If Right(pvPath, 1) <> "\" Then 884 pvPath = pvPath & "\" 885 End If 886 End If 887 888 If pIsPath Then 889 nDirAttrib = vbDirectory 890 Else 891 'File 892 nDirAttrib = vbNormal 893 End If 894 895 If Not Len(Dir(pvPath, nDirAttrib)) > 0 Then 896 'not found 897 Get_ColorDirectory = RGB(255, 0, 0) 'red 898 sControlTipText = "Directory does not exist" 899 booEnable = False 900 GoTo Proc_Exit 901 Else 902 'found 903 If psWhich = "BE" Then 904 'BACK END 905 If Right(pvPath, 1) <> "\" Then 906 pvPath = pvPath & "\" 907 End If 908 pvPath = pvPath & "*_be_*.*db" 'assume '_be_' is in the filename 909 If Len(Dir(pvPath, nDirAttrib)) > 0 Then 910 Get_ColorDirectory = RGB(255, 255, 255) 'white 911 sControlTipText = "Path " & psWhich 912 booEnable = True 913 GoTo Proc_Exit 914 Else 915 'path found but not file 916 Get_ColorDirectory = RGB(255, 200, 100) 'orange 917 sControlTipText = "Path found but no file" 918 GoTo Proc_Exit 919 End If 920 Else 921 'found 922 Get_ColorDirectory = RGB(255, 255, 255) 'white 923 sControlTipText = "Path found" 924 GoTo Proc_Exit 925 End If 926 End If 927 928 929 Proc_Exit: 930 On Error Resume Next 931 ' If Len(ctlname) > 0 Then 932 ' frm(ctlname).ControlTipText = sControlTipText 933 ' End If 934 ' If Len(ctlnameEnable) > 0 Then 935 ' frm(ctlnameEnable).Enabled = booEnable 936 ' End If 937 ' DoEvents 938 939 Exit Function 940 941 Proc_Err: 942 If Err.Number = 13 Then 'directory not found 943 'not found 944 Debug.Print pvPath 945 Get_ColorDirectory = RGB(255, 0, 0) 'red 946 Resume Proc_Exit 947 End If 948 MsgBox Err.Description, , _ 949 "ERROR " & Err.Number _ 950 & " Get_ColorDirectory " 951 Resume Proc_Exit 952 Resume 953 954 955 '13 -- not found 956 957 End Function |
958 959 960 '_________________________________________________ Get_DirectoryDialog 961 962 Public Function Get_DirectoryDialog( _ 963 Optional pvTitle As Variant _ 964 , Optional psStartPath As String = vbNullString _ 965 ) As String 966 '131110 strive4peace, 140102 967 968 'NEEDS REFERENCE 969 ' Microsoft Office #.# Object Library 970 971 Dim oFileDialog As Office.FileDialog 972 973 Set oFileDialog = Application.FileDialog(4) '4 = Folder Picker 974 975 With oFileDialog 976 977 .AllowMultiSelect = False 978 .Title = "Select folder " & (" for " + pvTitle) 979 If psStartPath <> vbNullString Then 980 If Right(psStartPath, 1) <> "\" Then psStartPath = psStartPath & "\" 981 .InitialFileName = psStartPath 982 End If 983 If .Show = True Then 984 Get_DirectoryDialog = .SelectedItems(1) 985 Else 986 Get_DirectoryDialog = vbNullString 987 End If 988 End With 989 Set oFileDialog = Nothing 990 End Function |
991 992 993 994 Public Function GetGoodPartOfPath( _ 995 Optional ByVal psPath As Variant = "") As String 996 '131125, 140102 strive4peace 997 'return the part of the path that is valid 998 999 Dim iPos As Integer _ 1,000 , sPath As String 1,001 1,002 sPath = psPath 1,003 1,004 If Len(Dir(sPath, vbDirectory)) > 0 Then 1,005 GetGoodPartOfPath = psPath 1,006 Exit Function 1,007 End If 1,008 1,009 Do While Len(sPath) > 0 1,010 If Right(sPath, 1) = "\" Then 1,011 sPath = Left(sPath, Len(sPath) - 1) 1,012 End If 1,013 iPos = InStrRev(sPath, "\") 1,014 sPath = Left(sPath, iPos) 1,015 If Len(Dir(sPath, vbDirectory)) > 0 Then 1,016 GetGoodPartOfPath = sPath 1,017 Exit Function 1,018 End If 1,019 Loop 1,020 1,021 GetGoodPartOfPath = "\" 1,022 1,023 End Function 1,024 |
1 Option Compare Database 2 Option Explicit 3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ |
29 30 Private Sub cmd_Attachments_Click() 31 '130908 32 On Error Resume Next 33 34 With Me.fc_AnywhereSub.Form 35 ' If .Dirty Then .Dirty = False 36 If Not .NewRecord Then 37 Call Set_Property("local_TID", .TID) 38 Call Set_Property("local_RecordID", .ID) 39 DoCmd.OpenForm "fc_AnywhereAttachments", , , , , acDialog 40 .Refresh 41 End If 42 End With 'Me 43 End Sub |
44 45 Private Sub cmd_AttachNote_Click() 46 '130908 47 On Error Resume Next 48 Dim nTID As Long _ 49 , nRecordID As Long 50 51 With Me.fc_AnywhereSub.Form 52 If Me.TID.Column(1) = "c_notes" Then 53 'popup form to see selected note instead of attaching 54 nTID = DLookup("TID", "c_notes", "NoteID=" & .ID) 55 nRecordID = DLookup("RecordID", "c_notes", "NoteID=" & .ID) 56 Call popNotes(Me, nTID, nRecordID) 57 Else 58 Call popNotes(Me, .TID, .ID) 59 End If 60 61 .Refresh 62 End With 'Me 63 End Sub |
64 65 66 67 Private Sub Form_Open(Cancel As Integer) 68 '120426 Crystal, 130919 69 With Me 70 .lstFieldname.RowSource = "Pick Table" 71 .TID.RowSource = .TID.Tag 72 .fc_AnywhereSub.SourceObject = "" 73 End With 'me 74 End Sub |
75 76 Private Sub Form_Load() 77 '120426 Crystal, 130919 78 On Error Resume Next 79 With Me 80 .SumSize = 0 81 End With 82 83 End Sub |
84 85 Private Sub fltrTablename_AfterUpdate() 86 '130425, 130919 87 Call RowSource_TID(Me.fltrTablename.Value) 88 End Sub |
89 90 Private Sub cmd_ClearFilter_Click() 91 '130919 Crystal 92 Me.fltrTablename.Value = Null 93 Call RowSource_TID(Me.fltrTablename.Value) 94 End Sub |
95 96 Private Sub RowSource_TID( _ 97 Optional varTableLike As Variant _ 98 , Optional booReset As Boolean = False _ 99 ) 100 '120426 Crystal 101 Dim sSQL As String _ 102 , varWhere As Variant _ 103 , iPos As Integer 104 105 sSQL = Me.TID.Tag 106 107 If Not IsNull(varTableLike) Then 108 iPos = InStr(sSQL, "WHERE ") + 5 109 sSQL = Left(sSQL, iPos) _ 110 & " (Tbl Like ""*" & varTableLike & "*"") AND " _ 111 & Mid(sSQL, iPos) 112 End If 113 114 Debug.Print sSQL 115 116 With Me.TID 117 .RowSource = sSQL 118 119 If booReset Then 120 .Requery 121 If IsNull(.Column(0)) Then 122 .Value = Null 123 Me.lstFieldname.RowSource = "Pick Table" 124 Me.lstFieldname.Requery 125 Me.SumSize = 0 126 End If 127 End If 128 .SetFocus 129 .Dropdown 130 End With 131 132 End Sub |
133 134 Private Sub TID_AfterUpdate() 135 ' 130427, 130913 136 Dim sTablename As String _ 137 , nTID As Long 138 139 Me.fc_AnywhereSub.SourceObject = "" 140 141 If IsNull(Me.TID) Then 142 Me.lstFieldname.RowSource = "Pick a Table" 143 Exit Sub 144 End If 145 146 With Me.TID 147 sTablename = .Column(1) 148 End With 'Me.TID 149 DoEvents 150 151 Call RowSource_Fieldlist(sTablename) 152 153 Call SourceObject_fc_AnywhereSub 154 End Sub |
155 156 Private Sub SourceObject_fc_AnywhereSub() 157 '130917 158 Dim nTID As Long _ 159 , sTablename As String _ 160 , sFriendlyTable As String _ 161 , sIDFieldname As String _ 162 , sEquation As String _ 163 , sSQL As String 164 165 With Me.TID 166 If IsNull(.Value) Then 167 Me.fc_AnywhereSub.SourceObject = "" 168 Exit Sub 169 End If 170 171 nTID = .Value 172 sTablename = .Column(1) 173 sFriendlyTable = .Column(2) 174 sIDFieldname = .Column(5) 175 sEquation = .Column(6) 176 177 sSQL = "SELECT tbl.[" & sIDFieldname & "] AS ID" _ 178 & ", " & sEquation & " AS Record " _ 179 & ", clng(DCount(""*"",""c_Attachments""" _ 180 & ",""TID=" & nTID & " AND RecordID= "" & " & sIDFieldname _ 181 & ")) AS NumAtt" _ 182 & ", clng(DCount(""*"",""c_Notes""" _ 183 & ",""TID=" & nTID & " AND RecordID= "" & " & sIDFieldname _ 184 & ")) AS NumNote" _ 185 & ", " & nTID & " AS TID " _ 186 & " FROM [" & sTablename & "] AS tbl " _ 187 & " ORDER BY " & sEquation & ";" 188 Call local_MakeQuery(sSQL, "c_qAnywhere") 189 End With 190 191 Me.fc_AnywhereSub.SourceObject = "fc_AnywhereSub" 192 193 End Sub |
194 195 Private Sub RowSource_Fieldlist(psTablename As String) 196 '130425, 26, 130427 197 198 'CALLS 199 ' dd_GetPropertyValue 200 ' local_GetDataType 201 ' dd_GetControlType 202 ' dd_CanGet_ObjectProperty (dd_CanGet_PropertyValue) 203 204 On Error GoTo Proc_Err 205 Dim sSQL As String _ 206 , sRowSource As String _ 207 , bBoo As Boolean _ 208 , sFieldname As String _ 209 , nSumSize As Long 210 211 212 sRowSource = "" 213 214 Dim db As DAO.Database _ 215 , tdf As DAO.TableDef _ 216 , fld As DAO.Field 217 218 If IsNull(Me.TID) Then GoTo Proc_WriteResults 219 220 Set db = CurrentDb 221 psTablename = Me.TID.Column(1) 222 Set tdf = db.TableDefs(psTablename) 223 224 For Each fld In tdf.Fields 225 With fld 226 227 sRowSource = sRowSource _ 228 & .Name & ";" _ 229 & local_GetDataType(.Type, True) & ";" _ 230 & .Size & ";" 231 nSumSize = nSumSize + .Size 'not taking unicode compression into account 232 End With 'fld 233 Next fld 234 If Len(sRowSource) > 0 Then 235 sRowSource = "Fieldname;DataType;Size;" & sRowSource 236 Else 237 sRowSource = "Pick Table" 238 End If 239 240 Proc_WriteResults: 241 Me.SumSize = nSumSize 242 243 With Me.lstFieldname 244 .Value = Null 245 .RowSource = sRowSource 246 .Requery 247 End With 248 249 Proc_Exit: 250 On Error Resume Next 251 Set fld = Nothing 252 Set tdf = Nothing 253 Set db = Nothing 254 Exit Sub 255 256 Proc_Err: 257 If Err.Number = 3265 Then 258 MsgBox "Cannot View Table: " & psTablename, , "Error" 259 sRowSource = "Pick Table" 260 Resume Proc_WriteResults 261 End If 262 MsgBox Err.Description, , _ 263 "ERROR " & Err.Number _ 264 & " RowSource_Fieldlist : " & Me.Name 265 266 Resume Proc_Exit 267 Resume 268 End Sub |
269 270 271 Private Sub TID_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 272 '130425 273 On Error Resume Next 274 Me.ActiveControl.Dropdown 275 End Sub |
276 277 Private Sub cmd_Design_Click() 278 '130425 279 Dim sTablename As String 280 If IsNull(Me.TID) Then Exit Sub 281 sTablename = Me.TID.Column(1) 282 DoCmd.OpenTable sTablename, acViewDesign 283 End Sub |
284 285 Private Sub cmd_Open_Click() 286 '130425 287 If IsNull(Me.TID) Then Exit Sub 288 Dim sTablename As String 289 sTablename = Me.TID.Column(1) 290 DoCmd.OpenTable sTablename, acViewNormal 291 End Sub |
292 293 Private Sub Label_By_Click() 294 On Error Resume Next 295 Application.FollowHyperlink _ 296 "mailto: strive4peace2010@yahoo.com?subject=Anywhere Contact comment " 297 End Sub |
298 299 300 301 Private Function local_GetDataType(ByVal pDataTypN As Long _ 302 , Optional pBooShort As Boolean = False _ 303 ) As String 304 305 '100310 306 307 local_GetDataType = "" 308 On Error Resume Next 309 310 Switch 311 Select Case Nz(pDataTypN) 312 Case 1: local_GetDataType = IIf(pBooShort, "YN", "Boolean") 313 Case 2: local_GetDataType = IIf(pBooShort, "Byt", "Byte") 314 Case 3: local_GetDataType = IIf(pBooShort, "Int", "Integer") 315 Case 4: local_GetDataType = IIf(pBooShort, "Lng", "Long") 316 Case 5: local_GetDataType = IIf(pBooShort, "Cur", "Currency") 317 Case 6: local_GetDataType = IIf(pBooShort, "Sgl", "Single") 318 Case 7: local_GetDataType = IIf(pBooShort, "Dbl", "Double") 319 Case 8: local_GetDataType = IIf(pBooShort, "DatT", "DateTime") 320 Case 10: local_GetDataType = IIf(pBooShort, "Txt", "Text") 321 Case 12: local_GetDataType = IIf(pBooShort, "Mem", "Memo") 322 323 Case 9: local_GetDataType = IIf(pBooShort, "Bin", "Binary") 324 Case 11: local_GetDataType = IIf(pBooShort, "Ole", "Ole BinBMP") 325 326 Case 15: local_GetDataType = IIf(pBooShort, "Guid", "GUID") 327 Case 16: local_GetDataType = IIf(pBooShort, "BigInt", "Big Integer") 328 Case 17: local_GetDataType = IIf(pBooShort, "BinVar", "Binary Variable") 329 330 ' Case 16: mStr = "Auto" 331 332 Case 18: local_GetDataType = IIf(pBooShort, "TxtFix", "Fixed Text") 333 334 Case 19: local_GetDataType = IIf(pBooShort, "oNum", "Numeric odbc") 335 Case 20: local_GetDataType = IIf(pBooShort, "oDec", "Decimal odbc") 336 Case 21: local_GetDataType = IIf(pBooShort, "oFlo", "Float odbc") 337 Case 22: local_GetDataType = IIf(pBooShort, "oTime", "Time odbc") 338 Case 23: local_GetDataType = IIf(pBooShort, "oDatT", "DateTime odbc") 339 340 Case 101: local_GetDataType = IIf(pBooShort, "att", "Attachment") 341 Case 102: local_GetDataType = IIf(pBooShort, "mvByt", "Byte MV") 342 Case 103: local_GetDataType = IIf(pBooShort, "mvInt", "Integer MV") 343 Case 104: local_GetDataType = IIf(pBooShort, "mvLng", "Long Integer MV") 344 Case 105: local_GetDataType = IIf(pBooShort, "mvSgl", "Single MV") 345 Case 106: local_GetDataType = IIf(pBooShort, "mvDbl", "Double MV") 346 Case 107: local_GetDataType = IIf(pBooShort, "mvGuid", "Guid MV") 347 Case 108: local_GetDataType = IIf(pBooShort, "mvDec", "Decimal MV") 348 Case 109: local_GetDataType = IIf(pBooShort, "mvTxt", "Text MV") 349 350 Case Else: local_GetDataType = Format(Nz(pDataTypN), "0") 351 End Select 352 End Function |
353 354 355 356 '~~~~~~~~~~~~~~~~~~~~~ MakeQuery 357 Private Sub local_MakeQuery( _ 358 ByVal pSQL As String, _ 359 ByVal qName As String) 360 361 'modified 3-30-08 -- meant to be a general Sub, included here for convenience 362 'crystal 363 'strive4peace2009 at yahoo dot com 364 365 On Error GoTo Proc_Err 366 367 Debug.Print pSQL 368 369 'if query already exists, update the SQL 370 'if not, create the query 371 372 If Nz(DLookup("[Name]", "MSysObjects", _ 373 "[Name]='" & qName _ 374 & "' And [Type]=5"), "") = "" Then 375 CurrentDb.CreateQueryDef qName, pSQL 376 Else 377 'if query is open, close it 378 On Error Resume Next 379 DoCmd.Close acQuery, qName, acSaveNo 380 On Error GoTo Proc_Err 381 CurrentDb.QueryDefs(qName).SQL = pSQL 382 End If 383 384 Proc_Exit: 385 CurrentDb.QueryDefs.Refresh 386 Application.RefreshDatabaseWindow 387 DoEvents 388 Exit Sub 389 390 Proc_Err: 391 MsgBox Err.Description, , _ 392 "ERROR " & Err.Number & " MakeQuery" 393 394 Resume Proc_Exit 395 396 'if you want to single-step code to find error, CTRL-Break at MsgBox 397 'then set this to be the next statement 398 Resume 399 End Sub 400 '~~~~~~~~~~~~~~~~~~~~~~~~~~ 401 |
1 Option Compare Database 2 Option Explicit 3 ' 4 'Crystal strive4peace June 2012 5 ' 6 ' POPUP a calendar to choose dates 7 ' updates the ActiveControl with DATE 8 ' ... and, optionally, TIME 9 '======================================================= 10 ' 11 ' code behind form: f_Calendar_sub 12 ' 13 '============================================================ LICENSE NOTICE -- must not be modified 14 ' This software is licensed to you under CC BY-NC-SA 3.0 15 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 16 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 17 ' 18 ' You are free to: 19 ' Share — copy and redistribute the material in any medium or format 20 ' Adapt — remix, transform, and build upon the material 21 ' The licensor cannot revoke these freedoms as long as you follow these terms: 22 ' Attribution — You must give appropriate credit, provide a link to the license, 23 ' and indicate if changes were made. 24 ' You may do so in any reasonable manner, 25 ' but not in any way that suggests the licensor endorses you or your use. 26 ' NonCommercial — You may not use the material for commercial purposes. 27 ' ShareAlike — If you remix, transform, or build upon the material, 28 ' you must distribute your contributions under the same license as the original. 29 ' 30 ' many procedures and module names contain author or controbitor names that must be left intact 31 ' if you make changes, add your name, date, and descriptive information to the comments 32 ' 33 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 34 ' ~ Crystal 35 ' * have an awesome day :) 36 ' www.AccessMVP.com/strive4peace 37 ' END LICENSE NOTICE 38 '============================================================' 39 ' me.txtCalendarDate holds the calendar date 40 ' 41 ' the sub Update_ExternalForms is for YOU to customize 42 ' in case you want to synchronize the calendar with other forms 43 ' |
44 45 '-------------------------------------------------------------------- external forms -- CUSTOMIZE 46 '---------------------------------------- Update_ExternalForms 47 Public Sub Update_ExternalForms(pDate As Variant) 48 '130119 49 50 On Error GoTo Proc_Err 51 Me.Parent.dtmAppt = pDate 52 53 Proc_Exit: 54 ' On Error Resume Next 55 Exit Sub 56 57 Proc_Err: 58 MsgBox Err.Description, , _ 59 "ERROR " & Err.Number _ 60 & " Update_ExternalForms : " & Me.Name 61 62 Resume Proc_Exit 63 Resume 64 End Sub |
65 66 67 68 Private Sub Form_Open(Cancel As Integer) 69 '130119 Crystal 70 Me.cmdMonth.Caption = Format(Date, "mmmm") 71 Me.cmdMonth.Tag = Format(Date, "m") 72 Me.cmdYr.Caption = Format(Date, "yyyy") 73 End Sub |
74 75 '-------------------------------------------------------------------- FORM 76 77 Private Sub Form_Load() 78 '120514, commented 120622, 23 79 ' sets the calendar to TODAY 80 ' unless a date is in the active control 81 ' or a date is passed in the OpenArgs 82 ' 83 ' CALLS 84 ' cal_cal_GetRow4Calendar 85 ' cal_cal_GetCol4Calendar 86 ' Set_Calendar 87 ' cal_ShowHideControlsTag 88 89 On Error GoTo Proc_Err 90 91 Dim nRow As Integer _ 92 , nCol As Integer _ 93 , iPos As Integer _ 94 , nDate As Date _ 95 , sStr As String 96 97 nDate = Date 98 99 nRow = cal_GetRow4Calendar(nDate) 100 nCol = cal_GetCol4Calendar(nDate) 101 102 'keep track so colors can be set back to normal 103 104 Me.txtRowPick = nRow 105 Me.txtColPick = nCol 106 Me.txtRowCur = nRow 107 Me.txtColCur = nCol 108 Me.txtCalendarDate = nDate 109 110 Set_Calendar nDate 111 112 Proc_Exit: 113 On Error Resume Next 114 Exit Sub 115 116 Proc_Err: 117 MsgBox Err.Description, , _ 118 "ERROR " & Err.Number _ 119 & " Form_Load : " & Me.Name 120 121 Resume Proc_Exit 122 Resume 123 End Sub |
124 125 126 '-------------------------------------------------------------------- CHANGE CALENDAR DAY 127 Public Sub DayClick() 128 '... 120622 129 130 ' CALLS 131 ' Set_Calendar 132 ' Update_ExternalForms 133 134 On Error GoTo Proc_Err 135 If Me.ActiveControl.Caption = "" Then 136 'user clicked on a day with no number - do nothing 137 Exit Sub 138 End If 139 140 Dim nRow As Integer _ 141 , nCol As Integer 142 143 Dim nDate As Date _ 144 , nDay As Integer 145 146 nDay = Me.ActiveControl.Caption 147 148 nDate = DateSerial(Me.cmdYr.Caption, Me.cmdMonth.Tag, nDay) 149 150 Set_Calendar nDate 151 Update_ExternalForms nDate 152 153 Proc_Exit: 154 On Error Resume Next 155 Exit Sub 156 157 Proc_Err: 158 MsgBox Err.Description, , _ 159 "ERROR " & Err.Number _ 160 & " DayClick : " & Me.Name 161 162 Resume Proc_Exit 163 Resume 164 End Sub |
165 166 Public Sub txtCalendarDate_AfterUpdate() 167 '120701 168 Dim nDate As Date 169 nDate = Me.txtCalendarDate 170 Set_Calendar nDate 171 Update_ExternalForms nDate 172 173 Proc_Exit: 174 On Error Resume Next 175 Exit Sub 176 Proc_Err: 177 Resume Proc_Exit 178 End Sub |
179 180 Private Sub cmdDayAdd_Click() 181 '120623 182 ' CALLS 183 ' Add_SetCalendar 184 ' Update_ExternalForms 185 186 Dim nDate As Date 187 nDate = Me.txtCalendarDate 188 Add_SetCalendar nDate, 0, 0, 1 189 Update_ExternalForms nDate 190 191 Proc_Exit: 192 On Error Resume Next 193 Exit Sub 194 Proc_Err: 195 Resume Proc_Exit 196 End Sub |
197 198 Private Sub cmdDaySub_Click() 199 '120623 200 ' CALLS 201 ' Add_SetCalendar 202 ' Update_ExternalForms 203 204 Dim nDate As Date 205 nDate = Me.txtCalendarDate 206 Add_SetCalendar nDate, 0, 0, -1 207 Update_ExternalForms nDate 208 209 Proc_Exit: 210 On Error Resume Next 211 Exit Sub 212 Proc_Err: 213 Resume Proc_Exit 214 End Sub 215 '--------------------------------------------------------------------- |
216 217 Private Sub cmd11_Click() 218 DayClick 219 End Sub |
220 221 Private Sub cmd12_Click() 222 DayClick 223 End Sub |
224 225 Private Sub cmd13_Click() 226 DayClick 227 End Sub |
228 229 Private Sub cmd14_Click() 230 DayClick 231 End Sub |
232 233 Private Sub cmd15_Click() 234 DayClick 235 End Sub |
236 237 Private Sub cmd16_Click() 238 DayClick 239 End Sub |
240 241 Private Sub cmd17_Click() 242 DayClick 243 End Sub |
244 245 Private Sub cmd21_Click() 246 DayClick 247 End Sub |
248 249 Private Sub cmd22_Click() 250 DayClick 251 End Sub |
252 253 Private Sub cmd23_Click() 254 DayClick 255 End Sub |
256 257 Private Sub cmd24_Click() 258 DayClick 259 End Sub |
260 261 Private Sub cmd25_Click() 262 DayClick 263 End Sub |
264 265 Private Sub cmd26_Click() 266 DayClick 267 End Sub |
268 269 Private Sub cmd27_Click() 270 DayClick 271 End Sub |
272 273 Private Sub cmd31_Click() 274 DayClick 275 End Sub |
276 277 Private Sub cmd32_Click() 278 DayClick 279 End Sub |
280 281 Private Sub cmd33_Click() 282 DayClick 283 End Sub |
284 285 Private Sub cmd34_Click() 286 DayClick 287 End Sub |
288 289 Private Sub cmd35_Click() 290 DayClick 291 End Sub |
292 293 Private Sub cmd36_Click() 294 DayClick 295 End Sub |
296 297 Private Sub cmd37_Click() 298 DayClick 299 End Sub |
300 301 Private Sub cmd41_Click() 302 DayClick 303 End Sub |
304 305 Private Sub cmd42_Click() 306 DayClick 307 End Sub |
308 309 Private Sub cmd43_Click() 310 DayClick 311 End Sub |
312 313 Private Sub cmd44_Click() 314 DayClick 315 End Sub |
316 317 Private Sub cmd45_Click() 318 DayClick 319 End Sub |
320 321 Private Sub cmd46_Click() 322 DayClick 323 End Sub |
324 325 Private Sub cmd47_Click() 326 DayClick 327 End Sub |
328 329 Private Sub cmd51_Click() 330 DayClick 331 End Sub |
332 333 Private Sub cmd52_Click() 334 DayClick 335 End Sub |
336 337 Private Sub cmd53_Click() 338 DayClick 339 End Sub |
340 341 Private Sub cmd54_Click() 342 DayClick 343 End Sub |
344 345 Private Sub cmd55_Click() 346 DayClick 347 End Sub |
348 349 Private Sub cmd56_Click() 350 DayClick 351 End Sub |
352 353 Private Sub cmd57_Click() 354 DayClick 355 End Sub |
356 357 Private Sub cmd61_Click() 358 DayClick 359 End Sub |
360 361 Private Sub cmd62_Click() 362 DayClick 363 End Sub |
364 365 Private Sub cmd63_Click() 366 DayClick 367 End Sub |
368 369 Private Sub cmd64_Click() 370 DayClick 371 End Sub |
372 373 Private Sub cmd65_Click() 374 DayClick 375 End Sub |
376 377 Private Sub cmd66_Click() 378 DayClick 379 End Sub |
380 381 Private Sub cmd67_Click() 382 DayClick 383 End Sub |
384 385 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Adjust Date 386 387 '-------------------------------------------------------------------- Add_SetCalendar 388 Public Sub Add_SetCalendar( _ 389 pDate As Date _ 390 , Optional pYearAdd As Integer = 0 _ 391 , Optional pMonthAdd As Integer = 0 _ 392 , Optional pDayAdd As Integer = 0 _ 393 ) 394 '120623 395 396 On Error GoTo Proc_Err 397 398 If pMonthAdd <> 0 Or pYearAdd <> 0 Or pDayAdd <> 0 Then 399 pDate = DateSerial(Year(pDate) + pYearAdd, Month(pDate) + pMonthAdd, Day(pDate) + pDayAdd) 400 End If 401 402 Set_Calendar pDate 403 404 Proc_Exit: 405 On Error Resume Next 406 Exit Sub 407 408 Proc_Err: 409 MsgBox Err.Description, , _ 410 "ERROR " & Err.Number _ 411 & " Add_SetCalendar" 412 413 Resume Proc_Exit 414 Resume 415 End Sub |
416 417 '-------------------------------------- CUSTOMIZE 418 '-------------------------------------------------------------------- Set_Calendar 419 Public Sub Set_Calendar( _ 420 pDate As Date _ 421 ) 422 '---------- CUSTOMIZE Defaults for -- Set_Calendar 423 424 'Crystal 120512, 13 425 '120623 remove need for Dates table 426 427 'set calendar to month for pDate 428 'and mark days 429 430 'PARAMETERS 431 'pDate - optional. if specified and > 1900, calendar will be set to the date 432 433 ' CALLS 434 ' cal_GetRow4Calendar 435 ' cal_GetCol4Calendar 436 ' Set_DefaultFormat 437 ' Mark_TodayAndDate 438 439 ' CALLED BY 440 ' Form Load and buttons to change calendar day 441 ' FormName: txtDate_AfterUpdate, FindTheDay, DayAddSub 442 443 On Error GoTo Proc_Err 444 445 '----- dimension variables 446 Dim ctl As Control _ 447 , db As DAO.Database _ 448 , rs As DAO.Recordset 449 450 Dim nMonth As Integer _ 451 , nYear As Integer _ 452 , nFirstCol As Integer _ 453 , nLastRow As Integer _ 454 , nLastCol As Integer _ 455 , iRow As Integer _ 456 , iCol As Integer _ 457 , nRowPick As Integer _ 458 , nColPick As Integer _ 459 , nRowCur As Integer _ 460 , nColCur As Integer _ 461 , sSQL As String _ 462 , sStr As String _ 463 , iDay As Integer 464 465 '----- set variables 466 467 nMonth = Month(pDate) 468 nYear = Year(pDate) 469 470 If Year(Date) = nYear And Month(Date) = nMonth Then 471 'calendar is showing the current month 472 nRowCur = cal_GetRow4Calendar(Date) 473 nColCur = cal_GetCol4Calendar(Date) 474 Else 475 'calendar is not showing the current month 476 nRowCur = 0 477 nColCur = 0 478 End If 479 480 nRowPick = cal_GetRow4Calendar(pDate) 481 nColPick = cal_GetCol4Calendar(pDate) 482 483 nLastCol = Weekday(DateSerial(nYear, nMonth + 1, 0)) 484 nLastRow = cal_GetRow4Calendar(DateSerial(nYear, nMonth + 1, 0)) 485 nFirstCol = Weekday(DateSerial(nYear, nMonth, 1)) 486 487 'keep track of picked day so colors can be set back to normal 488 'when the date is changed 489 490 ' If Me.txtRowPick <> nRowPick Then 491 ' Set_DefaultFormat Me("cmd" & Me.txtRowPick & Me.txtColPick), , False 492 ' Me.txtRowPick = nRowPick 493 ' Me.txtColPick = nColPick 494 ' End If 495 ' 496 ' If Me.txtRowCur <> nRowCur Then 497 ' 'reset previous current date if is was showing 498 ' If Me.txtRowCur <> 0 And Me.txtColCur <> 0 Then 499 ' Set_DefaultFormat Me("cmd" & Me.txtRowCur & Me.txtColCur), , False 500 ' End If 501 ' Me.txtRowCur = nRowCur 502 ' Me.txtColCur = nColCur 503 ' End If 504 505 If Me.txtRowPick <> nRowPick Then 506 If Not IsNull(Me.txtRowPick) Then 507 Set_DefaultFormat Me("cmd" & Me.txtRowPick & Me.txtColPick), , False 508 End If 509 Me.txtRowPick = nRowPick 510 Me.txtColPick = nColPick 511 End If 512 513 If Me.txtRowCur <> nRowCur Then 514 'reset previous current date if is was showing 515 If Not IsNull(Me.txtRowCur) Then 516 If Me.txtRowCur <> 0 And Me.txtColCur <> 0 Then 517 Set_DefaultFormat Me("cmd" & Me.txtRowCur & Me.txtColCur), , False 518 End If 519 End If 520 Me.txtRowCur = nRowCur 521 Me.txtColCur = nColCur 522 End If 523 524 Me.txtCalendarDate = pDate 525 Me.txtCalendarDate.Tag = "cmd" & nRowPick & nColPick 526 527 If nLastRow = 0 Or nLastCol = 0 Then 528 MsgBox "Error getting last row or column for calendar", , "Aborting" 529 Exit Sub 530 End If 531 532 'caption for cmdMonth 533 Me.cmdMonth.Caption = Format(pDate, "mmmm") 534 Me.cmdMonth.Tag = Format(pDate, "m") 535 Me.cmdYr.Caption = nYear 536 537 'hide unused squares in the first row 538 For iCol = 1 To (nFirstCol - 1) 539 Set ctl = Me("cmd1" & iCol) 540 With ctl 541 .Visible = False 542 End With 543 Next iCol 544 545 '----------------------------------------------------------------------- 546 ' reset visible cells to default format 547 548 iDay = 1 549 550 iRow = 1 551 iCol = 1 552 553 For iRow = 1 To 6 554 For iCol = 1 To 7 555 556 Set ctl = Me("cmd" & iRow & iCol) 557 558 Select Case iRow 559 Case 1 560 If iCol < nFirstCol Then 561 ctl.Visible = False 562 GoTo NextDay 563 Else 564 Set_DefaultFormat ctl, iDay, iCol, False 565 iDay = iDay + 1 566 End If 567 568 Case nLastRow 569 If iCol <= nLastCol Then 570 Set_DefaultFormat ctl, iDay, iCol, False 571 iDay = iDay + 1 572 Else 573 ctl.Visible = False 574 GoTo NextDay 575 End If 576 577 Case Is < nLastRow 578 Set_DefaultFormat ctl, iDay, iCol, False 579 iDay = iDay + 1 580 581 Case Is > nLastRow 582 ctl.Visible = False 583 GoTo NextDay 584 585 End Select 586 NextDay: 587 Next iCol 588 Next iRow 589 590 Call Mark_TodayAndDate(pDate) 591 592 Proc_Exit: 593 On Error Resume Next 594 Set ctl = Nothing 595 Exit Sub 596 597 Proc_Err: 598 MsgBox Err.Description, , _ 599 "ERROR " & Err.Number _ 600 & " Set_Calendar" 601 602 Resume Proc_Exit 603 Resume 604 End Sub |
605 606 Private Sub Set_DefaultFormat(pCtl As Control _ 607 , Optional iDay As Integer = 0 _ 608 , Optional iCol As Integer = 0 _ 609 , Optional BoldWkend As Boolean = True) 610 'Private Sub Set_DefaultFormat(pCtl As Control, Optional iDay As Integer = 0) 611 '120623, 120627, 120701 612 Dim booBold As Boolean 613 614 With pCtl 615 .Visible = True 616 .FontSize = 10 617 .ForeColor = 0 'black 618 booBold = True 619 If iDay > 0 Then 620 .Caption = iDay & Chr(160) & Chr(160) & Chr(160) & Chr(160) & vbCrLf & Chr(160) 621 If Not BoldWkend _ 622 And (iCol = 1 Or iCol = 7) Then 623 booBold = False 624 End If 625 End If 626 .BorderColor = Me.Detail.BackColor 627 .BorderWidth = 2 628 .FontBold = booBold 629 End With 630 End Sub |
631 632 Private Sub Mark_TodayAndDate(pDate As Date) 633 '120623, 120627, 120701 634 Dim nRow As Integer _ 635 , nCol As Integer _ 636 , sCtlName As String 637 638 'set format back for last current date 639 640 ' clear current date 641 If Not Format(pDate, "yyyymm") = Format(Date, "yyyymm") Then 642 'calendar is not showing current month 643 If Nz(Me.txtRowCur, 0) <> 0 And Nz(Me.txtColCur, 0) <> 0 Then 644 sCtlName = "cmd" & Me.txtRowCur & Me.txtColCur 645 Set_DefaultFormat Me(sCtlName) 646 End If 647 GoTo MarkScheduleDate 648 Else 649 nRow = cal_GetRow4Calendar(Date) 650 nCol = cal_GetCol4Calendar(Date) 651 sCtlName = "cmd" & nRow & nCol 652 With Me(sCtlName) 653 .ForeColor = RGB(255, 0, 0) 'red 654 .BorderWidth = 0 'hairline 655 .BorderColor = RGB(255, 0, 0) 656 End With 657 End If 658 659 ' ' clear pick date date 660 ' If Not Format(pDate, "yyyymm") = Format(Me.txtCalendarDate, "yyyymm") Then 661 ' 'pick date is different 662 ' If Nz(Me.txtRowPick, 0) <> 0 And Nz(Me.txtColPick, 0) <> 0 Then 663 ' sCtlName = "cmd" & Me.txtRowPick & Me.txtColPick 664 ' Set_DefaultFormat Me(sCtlName) 665 ' End If 666 ' End If 667 668 669 If pDate = Date Then 670 'make control purple if Pick = Today 671 With Me(sCtlName) 672 .ForeColor = RGB(150, 0, 250) 'purple 673 .BorderWidth = 0 'hairline 674 .BorderColor = RGB(150, 0, 250) 675 End With 676 GoTo Proc_Exit 677 End If 678 679 MarkScheduleDate: 680 'mark schedule date 681 nRow = cal_GetRow4Calendar(pDate) 682 nCol = cal_GetCol4Calendar(pDate) 683 sCtlName = "cmd" & nRow & nCol 684 685 With Me(sCtlName) 686 .ForeColor = RGB(0, 0, 255) 'blue 687 .BorderColor = RGB(0, 0, 255) 688 .BorderWidth = 0 'hairline 689 ' If IsSubform(Me) Then '120623 690 ' Me.Parent.Label_DayDesc.Caption = .ControlTipText 691 ' End If 692 End With 693 694 695 Proc_Exit: 696 On Error Resume Next 697 Exit Sub 698 End Sub |
699 700 Private Sub ShowDatePickerMessage() 701 '120701 702 MsgBox "To use this popup calendar in a form," _ 703 & " assign the DOUBLE-CLICK event " _ 704 & " of date control on a form to" & vbCrLf & vbCrLf _ 705 & " DoCmd.OpenForm ""f_PopupCalendar""" & vbCrLf & vbCrLf _ 706 & vbCrLf & vbCrLf _ 707 & "To use this in another database, " _ 708 & "import form f_PopupCalendar" _ 709 , , "Popup Calendar by Crystal" 710 711 End Sub |
712 713 '--------------------------------------------- general 714 715 Function cal_GetCardinalNumber(Optional pNumber) As String 716 '11-24-08 717 'written by fdcusa (John) 718 'modified by Crystal 719 720 'returns the string from a number in this form: 721 '1st, 2nd, 3rd, 10th, 301st, 1000th 722 723 If IsMissing(pNumber) Or IsNull(pNumber) Or (Not IsNumeric(pNumber)) Then Exit Function 724 725 Dim strEnding As String 726 727 'convert to string, get the last character 728 'then turn back into an integer for comparison 729 730 Select Case CInt(Right(CStr(pNumber), 1)) 731 Case 1: strEnding = "st" 732 Case 2: strEnding = "nd" 733 Case 3: strEnding = "rd" 734 Case Else: strEnding = "th" 735 End Select 736 737 cal_GetCardinalNumber = CStr(pNumber) & strEnding 738 739 End Function |
740 741 Public Function cal_GetCol4Calendar(pDate As Date) As Integer 742 cal_GetCol4Calendar = 0 743 cal_GetCol4Calendar = Weekday(pDate, vbSunday) 744 End Function |
745 746 Public Function cal_GetRow4Calendar(pDate As Date) As Integer 747 '120623 Crystal 748 749 On Error GoTo Proc_Err 750 cal_GetRow4Calendar = 0 751 752 Dim nCol_First As Integer _ 753 , nDate_First As Date _ 754 , nRow As Integer _ 755 , nCol As Integer _ 756 , nNumDaysRow1 As Integer 757 758 nDate_First = DateSerial(Year(pDate), Month(pDate), 1) 759 nCol_First = Weekday(nDate_First, vbSunday) 760 nNumDaysRow1 = 7 - nCol_First + 1 761 762 nCol = Weekday(pDate, vbSunday) 763 764 nRow = (Day(pDate)) \ 7 + 1 765 766 If Day(pDate) Mod 7 > nNumDaysRow1 Then nRow = nRow + 1 767 If Day(pDate) Mod 7 = 0 And nCol >= nCol_First Then nRow = nRow - 1 768 769 cal_GetRow4Calendar = nRow 770 771 Proc_Exit: 772 On Error Resume Next 773 Exit Function 774 775 Proc_Err: 776 MsgBox Err.Description, , _ 777 "ERROR " & Err.Number _ 778 & " cal_GetRow4Calendar" 779 780 Resume Proc_Exit 781 Resume 782 End Function |
783 784 Public Function cal_GetDowN4Calendar(pDate As Date) As Integer 785 '120623 Crystal 786 787 On Error GoTo Proc_Err 788 cal_GetDowN4Calendar = 0 789 790 Dim nDowN As Integer 791 792 nDowN = (Day(pDate)) \ 7 + 1 793 If Day(pDate) Mod 7 = 0 Then nDowN = nDowN - 1 794 795 cal_GetDowN4Calendar = nDowN 796 797 Proc_Exit: 798 On Error Resume Next 799 Exit Function 800 801 Proc_Err: 802 MsgBox Err.Description, , _ 803 "ERROR " & Err.Number _ 804 & " cal_GetDowN4Calendar" 805 806 Resume Proc_Exit 807 Resume 808 End Function |
809 810 811 '~~~~~~~~~~~~~~~~~~~~~~~~~~ IsSubform 812 Private Function cal_IsSubform(pForm As Form) As Boolean 813 '8-29-07 814 'return: 815 ' TRUE is specified form reference is being used as a subform 816 ' FALSE if it is not 817 818 'example useage: in code before parent controls are used 819 'If IsSubform(Me) then ... 820 821 On Error Resume Next 822 cal_IsSubform = _ 823 Not IsError(Len(pForm.Parent.Name) > 0) 824 825 End Function |
826 827 '~~~~~~~~~~~~~~~~~~~~~~~~~~ cal_ShowHideControlsTag 828 Private Function cal_ShowHideControlsTag( _ 829 pBoo As Boolean _ 830 , pTag As String) 831 832 833 On Error GoTo Proc_Err 834 835 Dim ctl As Control 836 837 On Error Resume Next 838 For Each ctl In Me.Detail.Controls 839 If InStr(ctl.Tag, pTag) > 0 Then 840 ctl.Visible = pBoo 841 End If 842 Next ctl 843 844 Proc_Exit: 845 If Not ctl Is Nothing Then Set ctl = Nothing 846 Exit Function 847 848 Proc_Err: 849 MsgBox Err.Description, , _ 850 "ERROR " & Err.Number _ 851 & " ShowHideControlsTag" 852 853 'press F8 to step through code 854 'comment next line when debugged 855 Stop: Resume 856 857 Resume Proc_Exit 858 859 End Function |
860 861 Private Function cal_GetRoman(ByVal pNumber As Integer) As String 862 '120627 863 'modified from Microsoft Support 864 ' OFF97: VBA Procedure to Convert Numbers to Roman Numerals 865 ' http://support.microsoft.com/kb/184657 866 867 On Error GoTo Proc_Err 868 869 Const ROMAN = "IVXLCDM" 'I=1,V=5, X=10, L=100, C=1,000, D=500 M=1,000 870 871 Dim i As Integer, Digit As Integer, sStr As String 872 873 i = 1 874 sStr = "" 875 Do While pNumber > 0 876 Digit = pNumber Mod 10 877 pNumber = pNumber \ 10 878 Select Case Digit 879 Case 1 880 sStr = Mid(ROMAN, i, 1) & sStr 881 Case 2 882 sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & sStr 883 Case 3 884 sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & _ 885 Mid(ROMAN, i, 1) & sStr 886 Case 4 887 sStr = Mid(ROMAN, i, 2) & sStr 888 Case 5 889 sStr = Mid(ROMAN, i + 1, 1) & sStr 890 Case 6 891 sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & sStr 892 Case 7 893 sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & _ 894 Mid(ROMAN, i, 1) & sStr 895 Case 8 896 sStr = Mid(ROMAN, i + 1, 1) & Mid(ROMAN, i, 1) & _ 897 Mid(ROMAN, i, 1) & Mid(ROMAN, i, 1) & sStr 898 Case 9 899 sStr = Mid(ROMAN, i, 1) & Mid(ROMAN, i + 2, 1) & sStr 900 End Select 901 i = i + 2 902 Loop 903 cal_GetRoman = sStr 904 905 Proc_Exit: 906 Exit Function 907 Proc_Err: 908 Resume Proc_Exit 909 910 End Function |
911 912 913 Private Sub Label_strive4peace_Click() 914 '120627 915 On Error Resume Next 916 Application.FollowHyperlink _ 917 "mailto: strive4peace2012@yahoo.com?subject=Calendar sub comment " 918 End Sub |
919 920 921 922 Private Sub txtCalendarDate_BeforeUpdate(Cancel As Integer) 923 '120701 924 On Error Resume Next 925 If IsNull(Me.ActiveControl) Then 926 Me.ActiveControl.Undo 927 Cancel = True 928 Exit Sub 929 End If 930 If Not IsDate(Me.ActiveControl) Then 931 MsgBox Me.ActiveControl & " is not a valid date", , "Cannot change" 932 Me.ActiveControl.Undo 933 Cancel = True 934 Exit Sub 935 End If 936 End Sub |
937 938 939 940 941 942 Private Sub cmdMonthAdd_Click() 943 '120512, 120622 944 ' CALLS 945 ' Add_SetCalendar 946 ' Update_ExternalForms 947 948 On Error GoTo Proc_Err 949 Dim nDate As Date 950 nDate = Me.txtCalendarDate 951 Add_SetCalendar nDate, 0, 1, 0 952 Update_ExternalForms nDate 953 954 Proc_Exit: 955 On Error Resume Next 956 Exit Sub 957 Proc_Err: 958 Resume Proc_Exit 959 End Sub |
960 961 Private Sub cmdMonthSub_Click() 962 '120512 Crystal, 120622 963 'move calendar back one month 964 ' 965 ' CALLS 966 ' Add_SetCalendar 967 ' Update_ExternalForms 968 On Error Resume Next 969 970 Dim nDate As Date 971 nDate = Me.txtCalendarDate 972 Add_SetCalendar nDate, 0, -1, 0 973 Update_ExternalForms nDate 974 975 End Sub |
976 977 978 979 Private Sub cmdYrAdd_Click() 980 '120512, 120622 981 ' CALLS 982 ' Add_SetCalendar 983 ' Update_ExternalForms 984 985 Dim nDate As Date 986 nDate = Me.txtCalendarDate 987 Add_SetCalendar nDate, 1, 0, 0 988 Update_ExternalForms nDate 989 990 Proc_Exit: 991 On Error Resume Next 992 Exit Sub 993 Proc_Err: 994 Resume Proc_Exit 995 End Sub |
996 997 Private Sub cmdYrSub_Click() 998 '120512, 120622 999 ' CALLS 1,000 ' Add_SetCalendar 1,001 ' Update_ExternalForms 1,002 1,003 Dim nDate As Date 1,004 nDate = Me.txtCalendarDate 1,005 Add_SetCalendar nDate, -1, 0, 0 1,006 Update_ExternalForms nDate 1,007 1,008 Proc_Exit: 1,009 On Error Resume Next 1,010 Exit Sub 1,011 Proc_Err: 1,012 Resume Proc_Exit 1,013 End Sub 1,014 |
1 Option Compare Database 2 Option Explicit |
3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ 29 Private Sub Form_Load() 30 '130119 Crystal 31 On Error GoTo Proc_Err 32 Dim i As Integer 33 For i = 1 To 3 34 With Me("Calendar" & i).Form 35 If Not IsNull(Me("Date" & i)) Then 36 .Set_Calendar Me("Date" & i) 37 Else 38 .Set_Calendar Date 39 End If 40 .Label_LinkControlname.Caption = "Date" & i 41 End With 42 Next i 43 Proc_Exit: 44 On Error Resume Next 45 Exit Sub 46 47 Proc_Err: 48 MsgBox Err.Description, , _ 49 "ERROR " & Err.Number _ 50 & " Form_Load : " & Me.Name 51 52 Resume Proc_Exit 53 Resume 54 End Sub |
55 56 Private Sub Label_emailCrystal_Click() 57 On Error Resume Next 58 Application.FollowHyperlink _ 59 "mailto: strive4peace2012@yahoo.com?subject=Calendar subform comment " 60 End Sub |
61 62 Private Sub Label_website_Click() 63 On Error Resume Next 64 Application.FollowHyperlink "http://www.AccessMVP.com/strive4peace" 65 End Sub |
66 67 Private Sub Date1_AfterUpdate() 68 '130119 69 If IsNull(Me.ActiveControl) Then Exit Sub 70 Me.Calendar1.Form.Set_Calendar Me.Date1 71 End Sub |
72 73 Private Sub Date2_AfterUpdate() 74 '130119 75 If IsNull(Me.ActiveControl) Then Exit Sub 76 Me.Calendar2.Form.Set_Calendar Me.Date2 77 End Sub |
78 79 80 Private Sub Date3_AfterUpdate() 81 '130119 82 If IsNull(Me.ActiveControl) Then Exit Sub 83 Me.Calendar3.Form.Set_Calendar Me.Date3 84 End Sub 85 |
1 Option Compare Database 2 Option Explicit 3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ |
29 30 31 Private Sub cmd_Add_Click() 32 '131002 33 Call RecordNew(Me, "CID") 34 DoEvents 35 Me.CID.Dropdown 36 End Sub |
37 38 Private Sub cmd_Del_Click() 39 '131002 40 MsgBox "Under construction" 41 End Sub |
42 43 Private Sub dtPurch_DblClick(Cancel As Integer) 44 '131002 45 'popup calendar for date purchased 46 DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 47 End Sub |
48 49 Private Sub dt1Bus_DblClick(Cancel As Integer) 50 DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 51 End Sub |
52 53 Private Sub fnd_Customer_AfterUpdate() 54 '131002 55 'find record by customer 56 Call FindRecordN(Me, "CustomerID", "CustRate") 57 End Sub |
58 59 Private Sub fnd_CustomerContact_AfterUpdate() 60 '131002 61 'find record by customer contact 62 Call FindRecordN(Me, "CustomerID", "CustRate") 63 End Sub |
64 65 Private Sub fnd_Project_AfterUpdate() 66 '131002 67 'find record by project name 68 Call FindRecordN(Me, "CustomerID", "CustRate") 69 End Sub |
70 71 Private Sub Form_BeforeUpdate(Cancel As Integer) 72 '131002 73 Call FormBeforeUpdate(Me) 74 End Sub |
75 76 Private Sub Form_Current() 77 '131002 78 Dim sSQL As String 79 80 With Me.lst_CompanyContacts 81 sSQL = Replace(.Tag, "ORDER BY" _ 82 , " WHERE c.[cid_]=" & Nz(Me.CID, -99) & " ORDER BY ") 83 If .RowSource <> sSQL Then 84 .RowSource = sSQL 85 .Requery 86 End If 87 End With 'Me.lst_CompanyContacts 88 89 'me.cid 90 ' If Me.NewRecord Then 'can't add records here -- filter CID for NOT ALREADY a CUSTOMER 91 ' sSQL = Replace(.Tag, "ORDER BY" _ 92 ' , "WHERE (((DLookUp(""CustomerID"",""Customers"",""CID="" & [c].[cid])) Is Null)) ORDER BY") 93 ' End If 94 95 End Sub |
1 Option Compare Database 2 Option Explicit 3 '============================================= 4 '============================================================ LICENSE NOTICE -- must not be modified 5 ' This software is licensed to you under CC BY-NC-SA 3.0 6 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 7 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 8 ' 9 ' You are free to: 10 ' Share — copy and redistribute the material in any medium or format 11 ' Adapt — remix, transform, and build upon the material 12 ' The licensor cannot revoke these freedoms as long as you follow these terms: 13 ' Attribution — You must give appropriate credit, provide a link to the license, 14 ' and indicate if changes were made. 15 ' You may do so in any reasonable manner, 16 ' but not in any way that suggests the licensor endorses you or your use. 17 ' NonCommercial — You may not use the material for commercial purposes. 18 ' ShareAlike — If you remix, transform, or build upon the material, 19 ' you must distribute your contributions under the same license as the original. 20 ' 21 ' many procedures and module names contain author or controbitor names that must be left intact 22 ' if you make changes, add your name, date, and descriptive information to the comments 23 ' 24 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 25 ' ~ Crystal 26 ' * have an awesome day :) 27 ' www.AccessMVP.com/strive4peace 28 ' END LICENSE NOTICE 29 '============================================================'============================================= 30 ' CALLS 31 ' dd_SetDisplayControlCheckbox 32 ' dd_SetDisplayControlTextbox 33 ' dd_GetPropertyValue 34 ' dd_GetDataType 35 ' dd_GetControlType 36 ' dd_CanGet_ObjectProperty (dd_CanGet_PropertyValue) |
37 38 Private Sub Form_Open(Cancel As Integer) 39 '120426 Crystal 40 RowSource_Tablename 41 With Me.lstFieldname 42 .RowSource = "Pick Table" 43 End With 44 End Sub |
45 46 Private Sub Form_Load() 47 '120426 Crystal 48 'CALL 49 ' RowSource_Tablename 50 51 Me.SumSize = 0 52 Me.Label_CheckUnicodeCompression.Visible = False 53 Me.cmd_Textbox.Enabled = False 54 Me.cmd_Checkbox.Enabled = False 55 56 Me.chkSys = False 57 Me.chkHid = False 58 Me.chkODBC = False 59 Me.chkLinked = False 60 Me.chkExclusive = False 61 Me.chkSavePW = False 62 Me.fltrTablename = Null 63 Me.chk_CorrectName = True 64 65 ' With Me.Tablename 66 ' .RowSource = .Tag 67 ' End With 68 End Sub |
69 70 Private Sub fltrTablename_AfterUpdate() 71 '130425 72 RowSource_TablenameForm 73 End Sub |
74 75 Private Sub chkSys_AfterUpdate() 76 RowSource_TablenameForm 77 End Sub |
78 79 Private Sub chkExclusive_Click() 80 '130426 Crystal 81 RowSource_TablenameForm 82 End Sub |
83 84 Private Sub chkHid_Click() 85 '130426 Crystal 86 RowSource_TablenameForm 87 End Sub |
88 89 Private Sub chkLinked_Click() 90 '130426 Crystal 91 RowSource_TablenameForm 92 End Sub |
93 94 Private Sub chkODBC_Click() 95 '130426 Crystal 96 RowSource_TablenameForm 97 End Sub |
98 99 Private Sub chkSavePW_Click() 100 '130426 Crystal 101 RowSource_TablenameForm 102 End Sub |
103 104 Private Sub RowSource_TablenameForm() 105 '130426 Crystal 106 RowSource_Tablename Me.fltrTablename, Me.chkSys, Me.chkHid _ 107 ', Me.chkODBC, Me.chkLinked, Me.chkExclusive, Me.chkSavePW 108 End Sub |
109 110 111 Private Sub RowSource_Tablename( _ 112 Optional varFilterOnName As Variant _ 113 , Optional booSys As Boolean = False _ 114 , Optional booHid As Boolean = False _ 115 , Optional booODBC As Boolean = True _ 116 , Optional booLinked As Boolean = True _ 117 , Optional booExclusive As Boolean = True _ 118 , Optional booSavePW As Boolean = True _ 119 , Optional booReset As Boolean = False _ 120 ) 121 '120426 Crystal 122 Dim sSQL As String _ 123 , varWhere As Variant 124 125 sSQL = "SELECT MSysObjects.Name" _ 126 & ", MSysObjects.DateUpdate AS Modified " _ 127 & ", GetTableFlags([MSysObjects].[Flags]) AS Flagz" _ 128 & " FROM MSysObjects" _ 129 130 varWhere = "(MSysObjects.Type = 1)" 'FUTURE: this needs to be conditional 131 132 If Not booSys Then 'assumption is NOT to show system objects 133 varWhere = (varWhere + " AND ") & "Not ([MSysObjects].[Flags] And -2147483646) " 134 End If 135 136 If booHid Then 'default is to show everything regardless of whether or not it is hidden 137 varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 1) " 138 End If 139 140 'different Type needs to be set to implement these 141 142 ' If booODBC Then 143 ' varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 536870912) " 144 ' End If 145 ' If booLinked Then 146 ' varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 1073741824) " 147 ' End If 148 ' 149 ' If booExclusive Then 150 ' varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 65536) " 151 ' End If 152 ' If booSavePW Then 153 ' varWhere = (varWhere + " AND ") & "([MSysObjects].[Flags] And 131072) " 154 ' End If 155 156 If Not IsNull(Me.fltrTablename) Then 157 varWhere = varWhere & " AND (MSysObjects.Name Like ""*" & Me.fltrTablename & "*"")" 158 End If 159 160 If Not IsNull(varWhere) Then 161 sSQL = sSQL & " WHERE " & varWhere 162 End If 163 164 sSQL = sSQL & " ORDER BY MSysObjects.Name;" 165 166 'Debug.Print sSQL 167 168 With Me.Tablename 169 .RowSource = sSQL 170 If booReset Then 171 .Requery 172 If IsNull(.Column(0)) Then 173 .Value = Null 174 Me.lstFieldname.RowSource = "Pick Table" 175 Me.lstFieldname.Requery 176 Me.SumSize = 0 177 Me.Label_CheckUnicodeCompression.Visible = False 178 End If 179 End If 180 .SetFocus 181 .Dropdown 182 End With 183 184 End Sub |
185 186 Private Sub Tablename_AfterUpdate() 187 ' 130427 188 RowSource_Fieldlist 189 End Sub |
190 191 Private Sub RowSource_Fieldlist() 192 '130425, 26, 130427 193 194 'CALLS 195 ' dd_GetPropertyValue 196 ' dd_GetDataType 197 ' dd_GetControlType 198 ' dd_CanGet_ObjectProperty (dd_CanGet_PropertyValue) 199 200 On Error GoTo Proc_Err 201 Dim sSQL As String _ 202 , sRowSource As String _ 203 , bytDisplayControl As Byte _ 204 , bBoo As Boolean _ 205 , bCheckUnicode As Boolean _ 206 , bHasIntegerNotCheckbox As Boolean _ 207 , bHasComboList As Boolean _ 208 , sTablename As String _ 209 , sFieldname As String _ 210 , nSumSize As Long _ 211 , sUni As String _ 212 , iMult As Integer 213 214 Dim varValue As Variant 215 216 nSumSize = 0 217 sRowSource = "" 218 bCheckUnicode = False 219 bHasComboList = False 220 bHasIntegerNotCheckbox = False 221 222 Dim db As DAO.Database _ 223 , tdf As DAO.TableDef _ 224 , fld As DAO.Field 225 226 If IsNull(Me.Tablename) Then GoTo Proc_WriteResults 227 228 Set db = CurrentDb 229 sTablename = Me.Tablename 230 Set tdf = db.TableDefs(sTablename) 231 232 For Each fld In tdf.Fields 233 iMult = 1 234 sUni = "" 235 With fld 236 bytDisplayControl = Nz(dd_GetPropertyValue(fld, "DisplayControl"), 0) 237 If bytDisplayControl = 109 Then 'textbox 238 bytDisplayControl = 0 239 ElseIf bytDisplayControl = 110 Or bytDisplayControl = 111 Then 240 bHasComboList = True 241 End If 242 243 '10 = text, 12 = memo 244 If .Type = 10 Or .Type = 12 Then 245 '1 = boolean 246 If dd_CanGet_ObjectProperty(fld, "UnicodeCompression", varValue, 1) Then 247 If Not CInt(varValue) = -1 Then 'no unicode compression 248 iMult = 2 249 sUni = "*" 250 bCheckUnicode = True 251 End If 252 End If 253 ElseIf .Type = 3 And bytDisplayControl <> 106 Then 254 'integer that is not already a checkbox 255 bHasIntegerNotCheckbox = True 256 End If 257 258 sRowSource = sRowSource _ 259 & .Name & ";" _ 260 & dd_GetDataType(.Type, True) & ";" _ 261 & .Size & sUni & ";" _ 262 & dd_GetControlType(bytDisplayControl) & ";" _ 263 & .Type & ";" _ 264 & bytDisplayControl & ";" 265 nSumSize = nSumSize + (.Size * iMult) 266 End With 'fld 267 Next fld 268 If Len(sRowSource) > 0 Then 269 sRowSource = "Fieldname;DataType;Size;Control;Type;DisplayControl;" & sRowSource 270 Else 271 sRowSource = "Pick Table" 272 End If 273 274 Proc_WriteResults: 275 Me.SumSize = nSumSize 276 Me.Label_CheckUnicodeCompression.Visible = bCheckUnicode 277 Me.cmd_Textbox.Enabled = bHasComboList 278 Me.cmd_Checkbox.Enabled = bHasIntegerNotCheckbox 279 280 With Me.lstFieldname 281 .Value = Null 282 .RowSource = sRowSource 283 .Requery 284 End With 285 286 Proc_Exit: 287 On Error Resume Next 288 Set fld = Nothing 289 Set tdf = Nothing 290 Set db = Nothing 291 Exit Sub 292 293 Proc_Err: 294 If Err.Number = 3265 Then 295 MsgBox "Cannot View Table", , "Error" 296 sRowSource = "Pick Table" 297 Resume Proc_WriteResults 298 End If 299 MsgBox Err.Description, , _ 300 "ERROR " & Err.Number _ 301 & " Tablename_AfterUpdate : " & Me.Name 302 303 Resume Proc_Exit 304 Resume 305 End Sub |
306 307 308 309 310 311 Private Sub Tablename_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 312 '130425 313 On Error Resume Next 314 Me.ActiveControl.Dropdown 315 End Sub |
316 317 318 319 Private Sub cmd_Design_Click() 320 '130425 321 Dim sTablename As String 322 If IsNull(Me.Tablename) Then Exit Sub 323 sTablename = Me.Tablename 324 DoCmd.OpenTable sTablename, acViewDesign 325 End Sub |
326 327 Private Sub cmd_Open_Click() 328 '130425 329 If IsNull(Me.Tablename) Then Exit Sub 330 Dim sTablename As String 331 sTablename = Me.Tablename 332 DoCmd.OpenTable sTablename, acViewNormal 333 End Sub |
334 335 Private Sub cmd_Checkbox_Click() 336 MakeTheChanges "dd_SetDisplayControlCheckbox", Me.ActiveControl 337 End Sub |
338 339 Private Sub cmd_Textbox_Click() 340 MakeTheChanges "dd_SetDisplayControlTextbox", Me.ActiveControl 341 End Sub |
342 343 Private Sub Label_By_Click() 344 On Error Resume Next 345 Application.FollowHyperlink _ 346 "mailto: strive4peace2010@yahoo.com?subject=Change DisplayControl Contact comment " 347 End Sub |
348 349 Private Sub MakeTheChanges(psProcedureName As String, ctl As Control) 350 351 Dim sTablename As String _ 352 , sFieldname As String _ 353 , sMsg As String _ 354 , varItem As Variant 355 356 With Me.Tablename 357 If IsNull(.Value) Then 358 .SetFocus 359 MsgBox "Table must be specified", , "Aborting" 360 .Dropdown 361 End If 362 End With 363 364 sTablename = Me.Tablename 365 sMsg = sTablename & vbCrLf & Space(3) 366 367 'NOTE (from Help): "The ItemsSelected collection is unlike other collections in that it is 368 'a collection of Variants rather than of objects. 369 'Each Variant is an integer index referring to a selected row in a list box or combo box." 370 371 With Me.lstFieldname 372 For Each varItem In .ItemsSelected 373 sFieldname = Nz(.Column(0, varItem), "") 374 sMsg = Application.Run(psProcedureName, sTablename, sFieldname, sMsg) 375 Next varItem 'selected field 376 End With 'field list 377 Me.txtMsg = "Table: " & sMsg 378 379 MsgBox "Done with " & psProcedureName, , "Done" 380 381 Call dd_ClearList(ctl) 382 Call Tablename_AfterUpdate 383 384 End Sub |
385 386 387 Private Sub lstFieldname_AfterUpdate() 388 '120426 Crystal 389 'would be more efficient to use ListBox1.Selected[ListBox1.Items.Count-1] to update LastSelected 390 391 Dim sMsg As String _ 392 , varItem As Variant _ 393 , sFieldname As String 394 395 Dim db As DAO.Database _ 396 , tdf As DAO.TableDef _ 397 , fld As DAO.Field 398 399 sMsg = "" 400 401 If IsNull(Me.Tablename) Then GoTo Proc_WriteResults 402 403 Set db = CurrentDb 404 405 Set tdf = db.TableDefs(Me.Tablename) 406 407 sMsg = "" 408 With Me.lstFieldname 409 For Each varItem In .ItemsSelected 410 sFieldname = Nz(.Column(0, varItem), "") 411 Set fld = tdf.Fields(sFieldname) 412 sMsg = sMsg _ 413 & vbCrLf & vbCrLf _ 414 & fld.Name & vbCrLf 415 416 417 'lookup RowSource 418 On Error Resume Next 419 sMsg = sMsg _ 420 & fld.Properties("RowSource") 421 On Error GoTo Proc_Err 422 Next varItem 'selected field 423 End With 'field list 424 If Len(sMsg) > 0 Then sMsg = "Selected Fields: " & sMsg 425 426 Proc_WriteResults: 427 With Me.txtMsg 428 .Value = sMsg 429 End With 430 Proc_Exit: 431 On Error Resume Next 432 Set fld = Nothing 433 Set tdf = Nothing 434 Set db = Nothing 435 Exit Sub 436 437 Proc_Err: 438 ' MsgBox Err.Description, , _ 439 "ERROR " & Err.Number _ 440 & " lstFieldname_AfterUpdate : " & Me.Name 441 442 Resume Proc_Exit 443 Resume 444 445 End Sub |
446 447 Private Sub cmdRename_Click() 448 '130427 449 If IsNull(Me.TableNameNew) Then 450 MsgBox "You have not typed in a new name", , "Can't rename" 451 Exit Sub 452 End If 453 If IsNull(Me.Tablename) Then 454 MsgBox "You have not selected a table to rename", , "Can't rename" 455 Exit Sub 456 End If 457 458 Dim sTableNameNew As String _ 459 , sCorrectName As String _ 460 , sTableNameOld As String _ 461 , sMsg As String 462 463 Dim db As DAO.Database 464 465 sTableNameOld = Me.Tablename 466 sTableNameNew = Trim(Me.TableNameNew) 467 468 If Me.chk_CorrectName Then 469 'user wants to remove bad characters from the name 470 471 sCorrectName = Get_CorrectName(sTableNameNew, True) 472 473 sMsg = "Correct the specified New Name, """"" & sTableNameNew & """ to:" _ 474 & vbCrLf & vbCrLf & """" & sCorrectName & """" _ 475 & vbCrLf & "?" 476 477 If sTableNameNew <> sCorrectName Then 478 If MsgBox(sMsg, vbYesNo, "Accept the suggested correction?") = vbNo Then 479 Exit Sub 480 End If 481 sTableNameNew = sCorrectName 482 Me.TableNameNew = sCorrectName 483 484 End If 485 End If 486 487 If sTableNameOld <> sTableNameNew Then 488 DoCmd.Rename sTableNameNew, acTable, sTableNameOld 489 Set db = CurrentDb 490 db.TableDefs.Refresh 491 DoEvents 492 Me.Tablename = sTableNameNew 493 If Not IsNull(Me.fltrTablename) Then 494 'clear filter if new tablename is not in it 495 If Not InStr(sTableNameNew, Me.fltrTablename) > 0 Then 496 Me.fltrTablename = Null 497 Call RowSource_Tablename(Null, Me.chkSys, Me.chkHid) 498 End If 499 Else 500 Me.Tablename.Requery 501 End If 502 End If 503 504 Me.TableNameNew = Null 505 506 End Sub 507 |
1 Option Compare Database 2 Option Explicit 3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ |
29 30 Private Sub fnd_EmpID_AfterUpdate() 31 '131002 32 Call FindRecordN(Me, "EmpID", "empNote") 33 End Sub |
34 35 Private Sub Form_BeforeUpdate(Cancel As Integer) 36 '131002 37 Call FormBeforeUpdate(Me) 38 End Sub 39 40 41 ' 42 'Private Sub Form_Current() 43 ''131002 44 ' Dim sSQL As String 45 ' 46 ' With Me.lst_CompanyContacts 47 ' sSQL = Replace(.Tag, "ORDER BY" _ 48 ' , " WHERE c.[cid_]=" & Nz(Me.CID, -99) & " ORDER BY ") 49 ' If .RowSource <> sSQL Then 50 ' .RowSource = sSQL 51 ' .Requery 52 ' End If 53 ' End With 'Me.lst_CompanyContacts 54 ' 55 ' 56 'End Sub 57 58 |
1 Option Compare Database |
2 '============================================================ LICENSE NOTICE -- must not be modified 3 ' This software is licensed to you under CC BY-NC-SA 3.0 4 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 5 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 6 ' 7 ' You are free to: 8 ' Share — copy and redistribute the material in any medium or format 9 ' Adapt — remix, transform, and build upon the material 10 ' The licensor cannot revoke these freedoms as long as you follow these terms: 11 ' Attribution — You must give appropriate credit, provide a link to the license, 12 ' and indicate if changes were made. 13 ' You may do so in any reasonable manner, 14 ' but not in any way that suggests the licensor endorses you or your use. 15 ' NonCommercial — You may not use the material for commercial purposes. 16 ' ShareAlike — If you remix, transform, or build upon the material, 17 ' you must distribute your contributions under the same license as the original. 18 ' 19 ' many procedures and module names contain author or controbitor names that must be left intact 20 ' if you make changes, add your name, date, and descriptive information to the comments 21 ' 22 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 23 ' ~ Crystal 24 ' * have an awesome day :) 25 ' www.AccessMVP.com/strive4peace 26 ' END LICENSE NOTICE 27 '============================================================ 28 Private Sub StatusID_GotFocus() 29 '140206 30 Dim nGrpID As Long 31 With Me.PaperID 32 If IsNull(.Value) Then 33 .SetFocus 34 .Dropdown 35 Exit Sub 36 End If 37 nGrpID = .Column(2) 38 End With 39 40 Call SetControl_RowSource(Me.StatusID _ 41 , "Statusez.GrpID=" & nGrpID) 42 43 End Sub |
44 45 Private Sub StatusID_LostFocus() 46 '140206 47 Call SetControl_RowSource(Me.StatusID) 48 49 End Sub |
1 Option Compare Database 2 Option Explicit |
3 4 Private Function ASDay(pNum As Integer) 5 On Error Resume Next 6 Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1), Day(Me.Date1) + pNum) 7 Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2), Day(Me.Date2) + pNum) 8 End Function |
9 10 Private Function ASMonth(pNum As Integer) 11 On Error Resume Next 12 Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1) + pNum, Day(Me.Date1)) 13 Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2) + pNum, Day(Me.Date2)) 14 End Function |
15 16 Private Function ASYear(pNum As Integer) 17 On Error Resume Next 18 Me.Date1 = DateSerial(Year(Me.Date1) + pNum, Month(Me.Date1), Day(Me.Date1)) 19 Me.Date2 = DateSerial(Year(Me.Date2) + pNum, Month(Me.Date2), Day(Me.Date2)) 20 End Function |
21 22 Private Function FillOneYear() 23 On Error Resume Next 24 Me.Date2 = Date - 1 25 Me.Date1 = DateSerial(Year(Me.Date2) - 1, Month(Me.Date2), Day(Me.Date2)) + 1 26 End Function |
27 28 Private Function FillQuarter(pQtr As Integer) 29 Dim mMonth As Integer, mEndQ As Integer, mYear As Integer 30 mMonth = Month(Date) 31 mEndQ = pQtr * 3 32 If mMonth > mEndQ Then mYear = Year(Date) Else mYear = Year(Date) - 1 33 Me.Date1 = DateSerial(mYear, mEndQ - 2, 1) 34 Me.Date2 = DateSerial(mYear, mEndQ + 1, 1) - 1 35 End Function |
36 37 Private Function FillDate(Optional pDate) 38 On Error Resume Next 39 If IsMissing(pDate) Then pDate = Date 40 Me.Date1 = pDate 41 Me.Date2 = pDate 42 End Function |
43 44 Private Function FillMTD() 45 On Error Resume Next 46 Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 47 Me.Date2 = Date 48 End Function |
49 50 Private Function FillYTD() 51 On Error Resume Next 52 Me.Date1 = DateSerial(Year(Date), 1, 1) 53 Me.Date2 = Date 54 End Function |
55 56 Private Function FillOneWeek() 57 On Error Resume Next 58 Me.Date1 = Date - 6 59 Me.Date2 = Date 60 End Function |
61 62 Private Function FillMonth() 63 On Error Resume Next 64 Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 65 Me.Date2 = DateSerial(Year(Date), Month(Date) + 1, 1) - 1 66 End Function |
67 68 Private Function FillWorkWeek() 69 Dim mDOW As Integer 70 mDOW = Weekday(Date) 71 Me.Date1 = Date - mDOW + 1 72 Me.Date2 = Me.Date1 + 6 73 End Function |
74 75 Private Sub cmd_Clear_Click() 76 '141007 77 Me.Date1 = Null 78 Me.Date2 = Null 79 End Sub |
80 81 Private Sub Date1_DblClick(Cancel As Integer) 82 '141011 83 Call PopCalendar(True) 84 End Sub |
85 86 Private Sub Date2_DblClick(Cancel As Integer) 87 '141011 88 Call PopCalendar(True, Me.Date1.Value) 89 90 End Sub |
1 Option Compare Database 2 Option Explicit |
3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ 29 Public Function CalculateTax() 30 Dim curTax As Currency _ 31 , curTotal As Currency 32 curTotal = 0 33 If Me.Dirty Then Me.Dirty = False 34 ' With Me.f_InvoiceDetail_sub.Form 35 ' If .Recordset.RecordCount > 0 Then 36 ' If .Dirty Then .Dirty = False 37 ' .txtSum.Requery 38 ' curTotal = curTotal + .txtSum 39 ' End If 40 ' End With 41 ' With Me.f_Invoice_Charges_sub.Form 42 ' If .Recordset.RecordCount > 0 Then 43 ' If .Dirty Then .Dirty = False 44 ' .txtSum.Requery 45 ' curTotal = curTotal + .txtSum 46 ' End If 47 ' End With 48 49 CurrentDb.TableDefs.Refresh 50 DoEvents 51 52 curTotal = Nz(DSum("qtyship * UnitPric" _ 53 , "InvOrdDetail", "ioid=" & Me.ioID), 0) _ 54 + Nz(DSum("AmtChg", "AddCharges", "ioid=" & Me.ioID), 0) 55 56 curTax = curTotal * Nz(Me.txtTaxRate, 0) 57 Me.AmtTax = CCur(Round(curTax, 2)) 58 Me.txtSum = curTotal + curTax 59 End Function |
60 61 Private Sub CIDCust_AfterUpdate() 62 '140623 63 With Me.CIDCust 64 If IsNull(.Value) Then Exit Sub 65 If Len(.Column(2)) > 0 Then 66 Me.txtTaxRate = CDbl(.Column(2)) 67 Me.Dirty = False 68 End If 69 End With 70 Call CalculateTax 71 End Sub |
72 73 Private Sub cmd_New_Click() 74 '140622 75 Dim nSeqNum As Long _ 76 , sSQL As String 77 If Not Me.NewRecord Then 78 DoCmd.RunCommand acCmdRecordsGoToNew 79 End If 80 Me.SeqNum = Nz(DMax("SeqNum", "InvOrd"), 2948) + 1 81 sSQL = "INSERT into AddCharges (InvOrdID, ChgTyID, AmtChg, ChgPc) " _ 82 & " SELECT InvOrdID, ChgTyID, AmtChg, ChgPcDf FROM VhgTypes" _ 83 & " WHERE ChgCat='I' and IsActiv;" 84 rSql sSQL 85 CurrentDb.TableDefs.Refresh 86 DoEvents 87 Me.f_Invoice_Charges_sub.Requery 88 End Sub |
89 90 Private Sub dtio_DblClick(Cancel As Integer) 91 '140622 92 DoCmd.OpenForm "f_PopupCalendar" 93 End Sub |
94 95 Private Sub Form_Current() 96 Call CIDCust_AfterUpdate 97 End Sub |
98 99 Private Sub txtTaxRate_AfterUpdate() 100 '140623 101 Call CalculateTax 102 End Sub |
1 Option Compare Database 2 Option Explicit |
3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ 29 Private Sub AmtChg_AfterUpdate() 30 Me.Dirty = False 31 Me.Parent.CalculateTax 32 End Sub |
1 Option Compare Database 2 Option Explicit 3 '======================================================= 4 ' f_Expenses_sub 5 '======================================================= 6 '============================================= 7 ' LICENSE NOTICE: 8 ' This code was originally written by Crystal (strive4peace) 9 ' strive4peace2012@yahoo.com 10 ' 131002 11 ' It is not to be altered or distributed, 12 ' except as part of a NON-COMMERCIAL application. 13 ' This License Notice must not be deleted. 14 ' 15 ' Licensed under Creative Commons 16 ' License name: Attribution-NonCommercial-ShareAlike 3.0 Unported (CC BY-NC-SA 3.0) 17 ' This license lets you remix, tweak, and build upon your work non-commercially, 18 ' as long as I am credited and you license your new creations under the identical terms. 19 ' You can download and redistribute my work, translate, make remixes, 20 ' and create new applications based on my work. 21 ' All new work based on my work must carry the same license, 22 ' so any derivatives will also be non-commercial in nature. 23 ' legal code: http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode 24 ' human-readable summary: http://creativecommons.org/licenses/by-nc-sa/3.0/ 25 ' ~ Crystal 26 ' www.AccessMVP.com/strive4peace 27 ' ~ have an awesome day :) 28 '============================================= 29 '======================================================= 30 'Private Sub SetMyRecordSource(Optional pBooAll As Boolean = False) 31 ''130908, 1002 32 ' On Error GoTo Proc_Err 33 ' Dim sSQL As String 34 ' sSQL = "SELECT Expenses.* FROM Expenses" 35 ' If Not pBooAll Then 36 ' sSQL = sSQL & " WHERE IsNull([InvoiceID]) " 37 ' End If 38 ' sSQL = sSQL & " ORDER BY Expenses.DtIDTran;" 39 ' Me.RecordSource = sSQL 40 ' 41 'Proc_Exit: 42 ' On Error Resume Next 43 ' Exit Sub 44 ' 45 'Proc_Err: 46 ' MsgBox Err.Description, , _ 47 ' "ERROR " & Err.Number _ 48 ' & " SetMyRecordSource : " & Me.Name 49 ' 50 ' Resume Proc_Exit 51 ' Resume 52 'End Sub |
53 54 Private Sub EmpID_AfterUpdate() 55 '131002 56 If Len(Me.EmpID.Column(2)) > 0 Then 57 Me.UnitCost = Me.EmpID.Column(2) 58 End If 59 End Sub 60 ' 61 'Private Sub Form_Open(Cancel As Integer) 62 ''130908, 1002 63 ' 'CALLS 64 ' ' SetMyRecordSource 65 ' 66 ' On Error GoTo Proc_Err 67 ' Dim sSQL As String _ 68 ' , booAll As Boolean 69 ' booAll = True 70 ' 71 ' If IsSubform(Me) Then 72 ' If InStr(Me.Parent.Name, "Project") > 0 Then 73 ' booAll = False 74 ' End If 75 ' End If 76 ' 77 ' Call SetMyRecordSource(booAll) 78 ' 79 'Proc_Exit: 80 ' On Error Resume Next 81 ' Exit Sub 82 ' 83 'Proc_Err: 84 ' MsgBox Err.Description, , _ 85 ' "ERROR " & Err.Number _ 86 ' & " Form_Open : " & Me.Name 87 ' 88 ' Resume Proc_Exit 89 ' Resume 90 'End Sub |
91 92 Private Sub Form_BeforeUpdate(Cancel As Integer) 93 '130907 94 On Error Resume Next 95 Me.dtmEdit = Now() 96 End Sub |
97 98 99 Private Sub DtIDTran_DblClick(Cancel As Integer) 100 '130906 101 DoCmd.OpenForm "f_PopupCalendar", , , , , acDialog 102 End Sub |
103 104 Private Sub TranTyID_AfterUpdate() 105 '130906 106 'ExpID=0: TIME 107 'any other Expense -- don't prompt for Employee or Hours 108 109 'column(3) = default UnitCost type 110 ' 4 = default expense AmtTran 111 112 On Error GoTo Proc_Err 113 114 Dim nQtyTyID As Long _ 115 , nAmtTran As Currency 116 117 Dim booFixedCost As Boolean 118 119 nAmtTran = 0 120 121 With Me 122 If IsNull(.TranTyID) Then 123 nQtyTyID = 1 124 Else 125 If Len(.TranTyID.Column(2)) > 0 Then 126 nQtyTyID = CLng(.TranTyID.Column(2)) 127 Me.QtyTyID = nQtyTyID 128 End If 129 If .TranTyID.Column(3) <> "" Then '--------- default is 0.00 ?? keep 130 nAmtTran = CCur(.TranTyID.Column(3)) 131 End If 132 If nAmtTran <> 0 Then 133 Me.AmtTran = nAmtTran 134 Else 135 Me.AmtTran = Null 136 End If 137 End If 138 139 'if Fixed UnitCost, don't stop at Employee, Hours, UnitCost 140 'if Fixed UnitCost, do stop at AmtTran 141 142 If nQtyTyID = 0 Then 'Fixed 143 booFixedCost = False 144 Else 145 booFixedCost = True 146 End If 147 148 Call SetTabStops(booFixedCost) 149 150 .AmtTran.TabStop = Not booFixedCost 151 152 End With 'me 153 154 Proc_Exit: 155 On Error Resume Next 156 Exit Sub 157 158 Proc_Err: 159 MsgBox Err.Description, , _ 160 "ERROR " & Err.Number _ 161 & " TranTyID_AfterUpdate : " & Me.Name 162 163 Resume Proc_Exit 164 Resume 165 End Sub |
166 167 Private Sub SetTabStops(ByVal booFixedCost As Boolean) 168 '131002 169 170 With Me 171 .AmtTran.TabStop = Not booFixedCost 172 173 .EmpID.TabStop = booFixedCost 174 .QtyTran.TabStop = booFixedCost 175 .UnitCost.TabStop = booFixedCost 176 If Not booFixedCost Then 177 .EmpID.Value = Null 178 .QtyTyID.Value = 0 'fixed 179 .QtyTran.Value = Null 180 .UnitCost.Value = Null 181 Else 182 'Time -- hourly or daily 183 If .QtyTyID.Value <> 0 Then 184 .QtyTyID = 1 'Hourly -- can be changed by user 185 End If 186 End If 187 188 End With 'me 189 190 Proc_Exit: 191 On Error Resume Next 192 Exit Sub 193 194 Proc_Err: 195 MsgBox Err.Description, , _ 196 "ERROR " & Err.Number _ 197 & " TranTyID_AfterUpdate : " & Me.Name 198 199 Resume Proc_Exit 200 Resume 201 End Sub |
202 203 204 Private Sub QtyTran_AfterUpdate() 205 '130908 206 Call CalculateAmtTran 207 End Sub |
208 209 Private Sub QtyTyID_AfterUpdate() 210 If IsNull(Me.QtyTyID) Then Exit Sub 211 Call SetTabStops((Me.QtyTyID = 0)) 212 End Sub |
213 214 Private Sub UnitCost_AfterUpdate() 215 '130906 216 Call CalculateAmtTran 217 End Sub |
218 219 Private Sub CalculateAmtTran() 220 '130906,8 221 222 On Error Resume Next 223 224 If Nz(Me.QtyTyID, 0) = 0 Then 'don't calculate if cost is FIXED 225 Exit Sub 226 End If 227 Me.AmtTran = Round(Nz(Me.QtyTran, 0) * Nz(Me.UnitCost, 0), 2) 228 229 ' Select Case Me.QtyTyID 230 ' Case 1 'hourly 231 ' Me.AmtTran = Round(Me.QtyTran * Me.UnitCost, 2) 232 ' Case 2 'daily 233 ' End Select 234 235 End Sub 236 |
1 Option Compare Database 2 Option Explicit |
3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ 29 Private Sub Form_AfterUpdate() 30 '140623 31 Call Me.Parent.CalculateTax 32 End Sub |
33 34 Private Sub fraItmBy_AfterUpdate() 35 '140620 36 Dim sSQL As String 37 38 Select Case Me.fraItmBy 39 Case 1 'Name 40 sSQL = "SELECT I.itmID " _ 41 & ", i.itmName " _ 42 & "& IIf(i.ItmCode<>i.itmName,(', '+i.ItmCode),'') " _ 43 & "& (IIf(i.itmid_<>i.itmID,(', ' & ip.itmName),'')) " _ 44 & "AS itm" _ 45 & ",i.ListPrice " _ 46 & " FROM Itms AS I " _ 47 & " LEFT JOIN Itms AS Ip ON I.itmID_ = Ip.itmID" _ 48 & " ORDER BY i.itmName,i.ItmCode,ip.itmName;" 49 50 Case 2 'Code 51 sSQL = "SELECT I.itmID " _ 52 & ", i.ItmCode " _ 53 & "& ', ' & i.itmName " _ 54 & "& (IIf(i.itmid_<>i.itmID,(', ' & ip.itmName),'')) " _ 55 & "AS itm" _ 56 & ",i.ListPrice " _ 57 & " FROM Itms AS I " _ 58 & " LEFT JOIN Itms AS Ip ON I.itmID_ = Ip.itmID" _ 59 & " ORDER BY i.ItmCode,i.itmName, ip.itmName;" 60 61 Case 3 'Category 62 sSQL = "SELECT I.itmID " _ 63 & ", trim(ip.itmName " _ 64 & "& ' ' & i.itmName " _ 65 & "& IIf(i.ItmCode<>i.itmName,(', '+i.ItmCode),'') " _ 66 & ") AS itm" _ 67 & ",i.ListPrice " _ 68 & " FROM Itms AS I " _ 69 & " LEFT JOIN Itms AS Ip ON I.itmID_ = Ip.itmID" _ 70 & " ORDER BY ip.itmName, i.itmName,i.ItmCode;" 71 72 End Select 73 With Me.ItmID 74 .RowSource = sSQL 75 .Requery 76 End With 77 78 End Sub |
79 80 81 Private Sub ItmID_AfterUpdate() 82 '140623 83 With Me.ItmID 84 If IsNull(.Value) Then Exit Sub 85 If Len(.Column(2)) > 0 Then 86 Me.UnitPric = .Column(2) 87 End If 88 End With 89 End Sub |
90 91 Private Sub QtyShip_AfterUpdate() 92 '140623 93 Me.Dirty = False 94 Call Me.Parent.CalculateTax 95 End Sub |
96 97 Private Sub UnitPric_AfterUpdate() 98 '140623 99 Me.Dirty = False 100 Call Me.Parent.CalculateTax 101 End Sub |
1 Option Compare Database 2 '============================================= 3 ' LICENSE NOTICE: 4 ' This code was originally written by Crystal Long (strive4peace) 5 ' strive4peace2010@yahoo.com 6 ' 130923 7 ' It is not to be altered or distributed, 8 ' except as part of a NON-COMMERCIAL application without written permission from Crystal Long 9 ' This License Notice must not be deleted. 10 ' 11 ' Licensed under Creative Commons 12 ' License name: Attribution-NonCommercial-ShareAlike 3.0 Unported (CC BY-NC-SA 3.0) 13 ' This license lets you remix, tweak, and build upon your work non-commercially, 14 ' as long as I am credited and you license your new creations under the identical terms. 15 ' You can download and redistribute my work, translate, make remixes, 16 ' and create new applications based on my work. 17 ' All new work based on my work must carry the same license, 18 ' so any derivatives will also be non-commercial in nature. 19 ' legal code: http://creativecommons.org/licenses/by-nc-sa/3.0/legalcode 20 ' human-readable summary: http://creativecommons.org/licenses/by-nc-sa/3.0/ 21 ' ~ Crystal 22 ' www.AccessMVP.com/strive4peace 23 ' ~ have an awesome day :) 24 '============================================= |
25 26 27 28 Private Sub Form_Open(Cancel As Integer) 29 '131114 30 'update transaction dates 31 Dim sSQL As String 32 sSQL = "UPDATE Jobs INNER JOIN Transactionz ON Jobs.JobID = Transactionz.JobID " _ 33 & " SET Transactionz.DtIDTran = CLng([dtmJob1]) " _ 34 & " WHERE ((Transactionz.DtIDTran Is Null) AND (Jobs.dtmJob1 Is Not Null));" 35 Call rSql(sSQL) 36 End Sub |
37 38 Private Sub Form_BeforeUpdate(Cancel As Integer) 39 '131002 40 'update the tracking fields 41 Call FormBeforeUpdate(Me) 42 End Sub |
43 44 Private Sub fnd_Invoice_AfterUpdate() 45 '131002 46 'find an invoice 47 Call FindRecordN(Me, "InvoiceID", "invNote") 48 End Sub |
49 50 Private Sub fnd_Project_AfterUpdate() 51 '131006 52 'find an invoice by Project 53 Call FindRecordN(Me, "InvoiceID", "invNote") 54 End Sub |
55 56 Private Sub fnd_PO_AfterUpdate() 57 '131115 58 'find an invoice by Project 59 Call FindRecordN(Me, "InvoiceID", "invNote") 60 End Sub 61 |
1 Option Compare Database 2 Option Explicit 3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ |
29 30 31 Private Sub Form_Load() 32 '140701 33 Dim nItmID As Long 34 'find a particular item if ItmID is in OpenArgs 35 With Me 36 If Len(.OpenArgs) > 0 Then 37 If IsNumeric(.OpenArgs) Then 38 nItmID = CLng(.OpenArgs) 39 Call FindRecordN(Me, "ItmID", "ItmName", nItmID) 40 End If 41 End If 42 End With 'me 43 End Sub |
44 45 Private Sub Form_BeforeUpdate(Cancel As Integer) 46 '140701 47 Me.dtmEdit = Now() 48 End Sub |
49 50 Private Sub cmd_Close_Click() 51 '140701 52 DoCmd.Close acForm, Me.Name, acSaveNo 53 End Sub |
54 55 Private Sub fltr_ItmID__AfterUpdate() 56 '140701 57 Call FilterMe 58 End Sub |
59 60 Private Sub Fnd_ItmID_Code_AfterUpdate() 61 '140701 62 Call FindRecordN(Me, "ItmID", "ItmName") 63 End Sub |
64 65 Private Sub Fnd_ItmID_Name_AfterUpdate() 66 '140701 67 Call FindRecordN(Me, "ItmID", "ItmName") 68 End Sub |
69 70 Private Sub Fnd_ItmID_SupCode_AfterUpdate() 71 '140701 72 Call FindRecordN(Me, "ItmID", "ItmName") 73 End Sub |
74 75 Private Sub cmd_Clear_fltr_ItmID__Click() 76 '140701 77 Me.fltr_ItmID_ = Null 78 Call FilterMe 79 End Sub |
80 81 Private Function FilterMe() As Boolean 82 '140701 83 'CALLS 84 ' SetControl_RowSource 85 ' 86 'Called By 87 ' cmd_Clear_fltr_ItmID_ 88 ' fltr_ItmID_ 89 90 On Error GoTo Proc_Err 91 92 Dim sSQL As String _ 93 , vWhere As Variant _ 94 , sOrderBy As String _ 95 , sEqn_Fullname As String _ 96 , iPos1 As Integer _ 97 , iPos2 As Integer 98 99 vWhere = Null 100 101 '-------------------------- Filter 102 With Me.fltr_ItmID_ 103 If Not IsNull(.Value) Then 104 vWhere = (vWhere + " AND ") & "i.ItmID_=" & .Value 105 Else 106 vWhere = "" 107 End If 108 End With 109 110 ' other FIND combo and listbox rowsources 111 Call SetControl_RowSource(Me.Fnd_ItmID_Code, vWhere) 112 Call SetControl_RowSource(Me.Fnd_ItmID_Name, vWhere) 113 Call SetControl_RowSource(Me.Fnd_ItmID_SupCode, vWhere) 114 115 With Me 116 If Len(vWhere) > 0 Then 117 If .FilterOn Or .Filter <> vWhere Then 118 .Filter = vWhere 119 .FilterOn = True 120 End If 'filter needs to change 121 Else 122 If .FilterOn Then .FilterOn = False 123 End If 124 End With 125 126 Proc_Exit: 127 On Error Resume Next 128 Exit Function 129 130 Proc_Err: 131 MsgBox Err.Description, , _ 132 "ERROR " & Err.Number _ 133 & " FilterMe : " & Me.Name 134 135 Resume Proc_Exit 136 Resume 137 End Function 138 139 140 141 |
1 Option Compare Database 2 Option Explicit 3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ |
29 30 31 Private Sub cmd_Close_Click() 32 '140701 33 DoCmd.Close acForm, Me.Name, acSaveNo 34 End Sub |
35 36 Private Sub fltr_ItmID__AfterUpdate() 37 '140701 38 Call FilterMe 39 End Sub |
40 41 Private Sub Fnd_ItmID_Code_AfterUpdate() 42 '140701 43 Call FindRecordN(Me, "ItmID", "ItmName") 44 End Sub |
45 46 47 48 Private Sub Fnd_ItmID_Name_AfterUpdate() 49 '140701 50 Call FindRecordN(Me, "ItmID", "ItmName") 51 End Sub |
52 53 Private Sub Fnd_ItmID_SupCode_AfterUpdate() 54 '140701 55 Call FindRecordN(Me, "ItmID", "ItmName") 56 End Sub |
57 58 Private Sub cmd_Clear_fltr_ItmID__Click() 59 '140701 60 Me.fltr_ItmID_ = Null 61 Call FilterMe 62 End Sub |
63 64 Private Function FilterMe() As Boolean 65 '140701 66 'CALLS 67 ' SetControl_RowSource 68 ' 69 'Called By 70 ' cmd_Clear_fltr_ItmID_ 71 ' fltr_ItmID_ 72 73 On Error GoTo Proc_Err 74 75 Dim sSQL As String _ 76 , vWhere As Variant _ 77 , sOrderBy As String _ 78 , sEqn_Fullname As String _ 79 , iPos1 As Integer _ 80 , iPos2 As Integer 81 82 vWhere = Null 83 84 '-------------------------- Filter 85 With Me.fltr_ItmID_ 86 If Not IsNull(.Value) Then 87 vWhere = (vWhere + " AND ") & "i.ItmID_=" & .Value 88 Else 89 vWhere = "" 90 End If 91 End With 92 93 ' other FIND combo and listbox rowsources 94 Call SetControl_RowSource(Me.Fnd_ItmID_Code, vWhere) 95 Call SetControl_RowSource(Me.Fnd_ItmID_Name, vWhere) 96 Call SetControl_RowSource(Me.Fnd_ItmID_SupCode, vWhere) 97 98 With Me 99 If Len(vWhere) > 0 Then 100 If .FilterOn Or .Filter <> vWhere Then 101 .Filter = vWhere 102 .FilterOn = True 103 End If 'filter needs to change 104 Else 105 If .FilterOn Then .FilterOn = False 106 End If 107 End With 108 109 Proc_Exit: 110 On Error Resume Next 111 Exit Function 112 113 Proc_Err: 114 MsgBox Err.Description, , _ 115 "ERROR " & Err.Number _ 116 & " FilterMe : " & Me.Name 117 118 Resume Proc_Exit 119 Resume 120 End Function |
121 122 Private Sub Form_BeforeUpdate(Cancel As Integer) 123 '140701 124 Me.dtmEdit = Now() 125 End Sub |
126 127 Private Sub OpenTheItem() 128 '140701 129 If Me.Dirty Then Me.Dirty = False 130 If Me.NewRecord Then Exit Sub 131 DoCmd.OpenForm "f_ITM", , , , , , Me.ItmID 132 End Sub |
133 134 Private Sub ItmCode_DblClick(Cancel As Integer) 135 '140701` 136 Call OpenTheItem 137 End Sub |
1 Option Compare Database 2 Option Explicit 3 '============================================================ LICENSE NOTICE -- must not be modified 4 ' This software is licensed to you under CC BY-NC-SA 3.0 5 ' Creative Commons Attribution-NonCommercial-ShareAlike 3.0 Unported 6 ' more information: http://creativecommons.org/licenses/by-nc-sa/3.0/ 7 ' 8 ' You are free to: 9 ' Share — copy and redistribute the material in any medium or format 10 ' Adapt — remix, transform, and build upon the material 11 ' The licensor cannot revoke these freedoms as long as you follow these terms: 12 ' Attribution — You must give appropriate credit, provide a link to the license, 13 ' and indicate if changes were made. 14 ' You may do so in any reasonable manner, 15 ' but not in any way that suggests the licensor endorses you or your use. 16 ' NonCommercial — You may not use the material for commercial purposes. 17 ' ShareAlike — If you remix, transform, or build upon the material, 18 ' you must distribute your contributions under the same license as the original. 19 ' 20 ' many procedures and module names contain author or controbitor names that must be left intact 21 ' if you make changes, add your name, date, and descriptive information to the comments 22 ' 23 ' thank you for sharing in the Access community ~ Crystal, strive4peace, 140629 24 ' ~ Crystal 25 ' * have an awesome day :) 26 ' www.AccessMVP.com/strive4peace 27 ' END LICENSE NOTICE 28 '============================================================ |
29 30 Private Sub cmd_Anywhere_Click() 31 '131002 32 DoCmd.OpenForm "f_AnywhereMENU" 33 End Sub |
34 35 Private Sub cmd_Contacts_Click() 36 '131001, 131010 37 If Not FoundBackEnd("c_KeepOpen") Then 38 Exit Sub 39 End If 40 DoCmd.OpenForm "fc_MENU_CONTACT" 41 End Sub |
42 43 Private Sub cmd_Customer_Click() 44 '131002, 131010 45 If Not FoundBackEnd("c_KeepOpen") Then 46 Exit Sub 47 End If 48 49 DoCmd.OpenForm "f_CUSTOMER" 50 End Sub |
51 52 Private Sub cmd_Demo_Click() 53 MsgBox "under construction" 54 End Sub |
55 56 Private Sub cmd_Employees_Click() 57 '131002, 131010 58 If Not FoundBackEnd("c_KeepOpen") Then 59 Exit Sub 60 End If 61 62 DoCmd.OpenForm "f_EMPLOYEE" 63 End Sub |
64 65 Private Sub cmd_Followup_Click() 66 MsgBox "under construction" 67 End Sub |
68 69 Private Sub cmd_Prospects_Click() 70 '131002, 131010 71 If Not FoundBackEnd("c_KeepOpen") Then 72 Exit Sub 73 End If 74 75 DoCmd.OpenForm "f_PROSPECT" 76 End Sub |
77 78 Private Sub cmd_Vendors_Click() 79 '131002, 131010 80 If Not FoundBackEnd("c_KeepOpen") Then 81 Exit Sub 82 End If 83 84 DoCmd.OpenForm "f_VENDOR" 85 End Sub |
86 87 Private Sub Form_Open(Cancel As Integer) 88 '131001 89 On Error Resume Next 90 Call Custom_SetDefaultProperties 91 Call SetPathAttachment(CurrentProject.Path) 92 93 End Sub |
1 Option Compare Database 2 Option Explicit 3 Option Base 1 'set arrays to start with 1 instead of 0 4 5 'crystal 6 'strive4peace2004@yahoo.ca 7 'modified 6-18-05 8 '5-15-06, 140929 9 10 ' main routine: Report_Calendar 11 12 'usys_REPORTMENU_Calendar 13 'CALLS 14 ' MkDir 15 16 17 Dim mvCrit As Variant _ 18 , msUserCriteria As String 19 20 Dim gStartTime As Date 21 22 23 Const gNUMREPORTS As Integer = 1 '1 = Calendar Report (the ONLY report) -- used to color command button(s) |
24 25 26 Private Sub btnClearDates_Click() 27 '140929 28 Me.Date1 = Null 29 Me.Date2 = Null 30 End Sub |
31 32 Private Sub cal_MoAdd_Click() 33 '140930 34 Call ASMonth(1) 35 End Sub |
36 37 Private Sub cal_Month_Click() 38 '140930 39 Call FillMonth 40 End Sub |
41 42 Private Sub cal_MoSub_Click() 43 '140930 44 Call ASMonth(-1) 45 End Sub |
46 47 Private Sub cal_MTD_Click() 48 '140930 49 Call FillMTD 50 End Sub |
51 52 Private Sub cal_Q1_Click() 53 '140930 54 Call FillQuarter(1) 55 End Sub |
56 57 Private Sub cal_Q2_Click() 58 '140930 59 Call FillQuarter(2) 60 End Sub |
61 62 Private Sub cal_Q3_Click() 63 '140930 64 Call FillQuarter(3) 65 End Sub |
66 67 Private Sub cal_Q4_Click() 68 '140930 69 Call FillQuarter(4) 70 End Sub |
71 72 Private Sub cal_Today_Click() 73 '140930 74 Call FillDate(Date) 75 End Sub |
76 77 Private Sub cal_Week_Click() 78 '140930 79 Call FillOneWeek 80 End Sub |
81 82 Private Sub cal_WorkWeek_Click() 83 '140930 84 Call FillWorkWeek 85 End Sub |
86 87 Private Sub cal_YrAdd_Click() 88 '140929 89 Call ASYear(1) 90 End Sub |
91 92 Private Sub cal_YrSub_Click() 93 '140929 94 Call ASYear(-1) 95 End Sub |
96 97 Private Sub CalTitle_DblClick(Cancel As Integer) 98 '140929 99 Call CorrectCase 100 End Sub |
101 102 Private Sub chkOpen_AfterUpdate() 103 Call BoldMe 104 End Sub |
105 106 Private Sub Color3_AfterUpdate() 107 '140930 108 Call ColorMe 109 End Sub |
110 111 Private Sub Color3B_AfterUpdate() 112 '140930 113 Call ColorMe 114 End Sub |
115 116 Private Sub ColorMe() 117 '140930 118 Dim sColor As String 119 120 121 With Me.ActiveControl 122 If IsNull(.Value) Then 123 sColor = "000000" 124 Me.ActiveControl.Value = "000000" 125 Else 126 sColor = .Value 127 End If 128 .Controls(0).ForeColor = RGB(CLng("&H" & Left(sColor, 2)) _ 129 , CLng("&H" & Mid(sColor, 3, 2)) _ 130 , CLng("&H" & Right(sColor, 2))) 131 End With 132 End Sub |
133 134 Private Sub Date1_DblClick(Cancel As Integer) 135 '140929 136 Call open_Form("f_PopupCalendar") 137 End Sub |
138 139 Private Sub Date2_DblClick(Cancel As Integer) 140 '140929 141 Call open_Form("f_PopupCalendar") 142 End Sub |
143 144 Private Sub EmailAddress_AfterUpdate() 145 '140929 146 Call CheckEmailOptions 147 End Sub |
148 149 Private Sub Examples1_DblClick(Cancel As Integer) 150 Call RequeryMe 151 End Sub |
152 153 Private Sub Examples2_DblClick(Cancel As Integer) 154 Call RequeryMe 155 End Sub |
156 157 Private Sub Examples3_DblClick(Cancel As Integer) 158 Call RequeryMe 159 End Sub |
160 161 Private Sub Examples4_DblClick(Cancel As Integer) 162 Call RequeryMe 163 End Sub |
164 165 Private Sub Field1_AfterUpdate() 166 Call SQL_Examples 167 End Sub |
168 169 Private Sub Field2_AfterUpdate() 170 Call SQL_Examples 171 End Sub |
172 173 Private Sub Field3_AfterUpdate() 174 'MsgBox Me.Field3.Column(0) ' ---------------- error 175 Call SQL_Examples 176 End Sub |
177 178 179 Private Sub btn1_Click() 180 '130814, 140929 181 On Error GoTo Proc_Err 182 183 Call Report_Calendar 184 Proc_Exit: 185 On Error Resume Next 186 Exit Sub 187 188 Proc_Err: 189 MsgBox Err.Description, , _ 190 "ERROR " & Err.Number _ 191 & " btn1_Click : " & Me.Name 192 End Sub |
193 194 195 196 Private Sub Field4_AfterUpdate() 197 Call SQL_Examples 198 End Sub |
199 200 Private Sub Form_Load() 201 On Error GoTo Proc_Err 202 203 Call ResetData 204 Me.fraOutput = 1 205 206 Dim nColor As Long _ 207 , i As Integer 208 209 nColor = 8388608 210 For i = 1 To gNUMREPORTS 211 Me("btn" & i).BackColor = nColor 212 Next i 213 SQL_TQ 1 214 215 Proc_Exit: 216 Exit Sub 217 218 'if there is an error, the following code will execute 219 Proc_Err: 220 MsgBox Err.Description, , "ERROR " & Err.Number & " SQL_TQ " 221 'press F8 to step through code and debug 222 'remove next line after debugged 223 Stop: Resume 224 Resume Proc_Exit 225 End Sub |
226 227 228 '------------------------------------------------------ SQL_TQ 229 230 Private Function SQL_TQ(pWhich As Integer) 231 On Error GoTo Proc_Err 232 233 Dim s As String, i As Integer, mType As Long 234 s = "" 235 236 Me.SQL_ListTQ.Visible = IIf(pWhich = 2, True, False) 237 238 Call ResetData 239 240 If pWhich = 2 Then 241 'Queries 242 mType = 5 243 Else 244 'Tables 245 mType = 1 246 End If 247 248 s = "SELECT M.Name, M.DateCreate, M.DateUpdate " _ 249 & " FROM MSysObjects AS M " _ 250 & " WHERE ((m.Type = " & mType _ 251 & ") And (Left([Name], 1) <> '~') And (Left([Name], 4) <> 'msys')) " _ 252 & " ORDER BY M.Name;" 253 254 '~~~CL 255 Me.btn1.SetFocus 256 257 Me.ListTQ = Null 258 Me.ListTQ.RowSource = s 259 Me.ListTQ.Requery 260 261 DoEvents 262 263 Proc_Exit: 264 Exit Function 265 266 'if there is an error, the following code will execute 267 Proc_Err: 268 MsgBox Err.Description, , "ERROR " & Err.Number & " SQL_TQ " & pWhich 269 'press F8 to step through code and debug 270 'remove next line after debugged 271 Stop: Resume 272 Resume Proc_Exit 273 End Function |
274 275 '------------------------------------------------------ SQL_Fields 276 Private Function SQL_Fields() 277 278 On Error GoTo Proc_Err 279 280 Dim i As Integer _ 281 , iList As Integer _ 282 , sName As String _ 283 , sSQL As String _ 284 , nType As Long _ 285 , boo As Boolean _ 286 , sListType As String 287 288 sSQL = "" 289 If IsNull(Me.ListTQ) Then sName = "" 290 sName = Me.ListTQ 291 Me.SQL_ListTQ = "" 292 293 Me.label_FooterCalc1.Visible = False 294 Me.label_FooterCalc2.Visible = False 295 Me.prompt_FooterCalc1.Visible = False 296 Me.prompt_FooterCalc2.Visible = False 297 298 Me.label_Footer1.Visible = False 299 Me.prompt_Footer1.Visible = False 300 Me.label_Footer2.Visible = False 301 Me.prompt_Footer2.Visible = False 302 Me.label_Footer3.Visible = False 303 Me.prompt_Footer3.Visible = False 304 305 For iList = 1 To 4 306 Select Case iList 307 Case 1: sListType = "Date" 308 Case 2: sListType = "Long" 309 Case 3: sListType = "" 310 Case 4: sListType = "Number" 311 End Select 312 sSQL = "" 313 If Nz(Me.FraTQ, 1) = 2 Then 314 'Queries 315 With CurrentDb.QueryDefs(sName) 316 For i = 0 To .Fields.Count - 1 317 nType = Nz(.Fields(i).Type) 318 boo = False 319 Select Case Trim(sListType) 320 Case "": boo = True 321 Case "Text": If nType = 10 Or nType = 12 Then boo = True 322 Case "Number": If nType >= 1 And nType <= 7 Then boo = True 323 Case "Date": If nType = 8 Then boo = True 324 Case "Long": If nType = 4 Then boo = True 325 End Select 326 If boo And Len(Trim(sName)) > 0 Then 327 sSQL = sSQL & """" & .Fields(i).Name & """;" 328 sSQL = sSQL & """" & GetDataType(nType) & """;" 329 sSQL = sSQL & nType & ";" 330 sSQL = sSQL & .Fields(i).SourceTable _ 331 & ("." + .Fields(i).SourceField) _ 332 & ";" 333 End If 334 Next i 335 End With 336 Else 337 'Tables 338 With CurrentDb.TableDefs(sName) 339 For i = 0 To .Fields.Count - 1 340 nType = .Fields(i).Type 341 boo = False 342 Select Case Trim(sListType) 343 Case "": boo = True 344 Case "Text": If nType = 10 Or nType = 12 Then boo = True 345 Case "Number": If nType >= 1 And nType <= 7 Then boo = True 346 Case "Date": If nType = 8 Then boo = True 347 Case "Long": If nType = 4 Then boo = True 348 End Select 349 If boo And Len(Trim(sName)) > 0 Then 350 sSQL = sSQL & """" & .Fields(i).Name & """;" 351 sSQL = sSQL & """" & GetDataType(nType) & """;" 352 sSQL = sSQL & nType & ";" 353 sSQL = sSQL & .Fields(i).SourceTable _ 354 & "." & .Fields(i).SourceField _ 355 & ";" 356 End If 357 Next i 358 End With 'CurrentDb.TableDefs(sName) 359 End If 360 Me("Field" & iList) = Null 361 Me("Field" & iList).RowSource = sSQL 362 Me("Field" & iList).Requery 363 364 Me("Examples" & iList) = Null 365 Me("Examples" & iList).RowSource = "" 366 Me("Examples" & iList).Requery 367 Next iList 368 369 If Me.FraTQ = 2 Then 370 Me.SQL_ListTQ = Nz(CurrentDb.QueryDefs(Me.[ListTQ]).SQL) 371 Else 372 Me.SQL_ListTQ = sName 373 End If 374 375 Me.fraSumcount = 3 376 Me.fraSumcount.Enabled = False 377 Me.Label_fraSumcount.Visible = False 378 379 Proc_Exit: 380 381 Exit Function 382 383 Proc_Err: 384 MsgBox Err.Description, , "ERROR " & Err.Number & " SQL_Fields" 385 'press F8 to step through code and fix problem 386 Stop: Resume 387 Resume Proc_Exit 388 389 End Function |
390 391 392 '------------------------------------------------------ SQL_Examples 393 Private Function SQL_Examples() 394 'on AfterUpdate event of each Field List 395 '140930 counts to get better equation 396 397 On Error GoTo Proc_Err 398 399 400 Dim sSQL As String _ 401 , sFld As String _ 402 , sControlnameList As String _ 403 , sSource As String _ 404 , sDateField As String 405 406 Dim iListNum As Integer _ 407 , boo As Boolean _ 408 , sAlias As String 409 Dim iNum3 As Integer _ 410 , sFieldname As String 411 412 Dim iPos1 As Integer _ 413 , iPos2 As Integer _ 414 , i As Integer _ 415 , sChar As String * 1 416 ', booInDelimited As Boolean _ 417 418 Dim iCountBracket As Integer _ 419 , iCountParenthesis As Integer _ 420 , iCountSingleQuote As Integer _ 421 , iCountDoubleQuote As Integer _ 422 , iCount As Integer 423 424 Dim varItem As Variant 425 426 sControlnameList = Me.ActiveControl.Name 427 iListNum = CInt(Right(sControlnameList, 1)) 428 DoEvents 429 430 Me.btn1.SetFocus 431 432 '~CL 433 sFld = "" 434 sAlias = "" 435 sSQL = "" 436 437 iNum3 = 0 438 sFieldname = "" 439 sSource = "" 440 441 Select Case iListNum 442 443 Case 1, 2 444 445 boo = IsNull(Me.Field2.Column(0)) 446 447 Me.label_FooterCalc1.Visible = boo 448 Me.prompt_FooterCalc1.Visible = boo 449 450 Me.label_Footer1.Visible = boo 451 Me.prompt_Footer1.Visible = boo 452 Me.label_Footer2.Visible = boo 453 Me.prompt_Footer2.Visible = boo 454 455 boo = True 456 457 If IsNull(Me("Field" & iListNum)) Then 458 GoTo Assign_RowSource 459 End If 460 461 sFieldname = Me("Field" & iListNum) 462 sFld = "[" & sFieldname & "]" 463 464 Case 3 465 'multi-select listbox 466 With Me.Field3 467 For Each varItem In .ItemsSelected 468 469 sFld = sFld & "Trim([" _ 470 & .ItemData(varItem) & "]) & ' ' & " 471 472 sFieldname = .ItemData(varItem) 473 474 sSource = Trim(Nz(.Column(3, varItem))) 475 476 sAlias = sAlias & Trim(.ItemData(varItem)) & "_" 477 478 iNum3 = iNum3 + 1 479 Next varItem 480 End With 'Field3 481 482 If Len(sFld) = 0 Then 483 Me.Field3eqn = Null 484 Me.Field3Alias = Null 485 GoTo Assign_RowSource 486 End If 487 488 sFld = "(" & Left(sFld, Len(sFld) - 9) & ")" 489 boo = True 490 491 If iNum3 = 1 Then 'if there is only one field, do it this way instead 492 sFld = "[" & sFieldname & "]" 493 End If 494 495 Me.Field3eqn = sFld 496 Me.Field3Alias = IIf(Len(sAlias) = 0, Nz(Me.Source3, ""), sAlias) 497 498 Case 4 499 boo = IIf(IsNull(Me.Field4), False, True) 500 501 Me.fraSumcount.Enabled = boo 502 Me.Label_fraSumcount.Visible = boo 503 Me.label_FooterCalc2.Visible = boo 504 Me.label_Footer3.Visible = boo 505 Me.prompt_Footer3.Visible = boo 506 sFieldname = Me.Field4 507 sFld = "[" & Me.Field4 & "]" 508 509 End Select 510 511 If sSource = "" Then sSource = Trim(Nz(Me(sControlnameList).Column(3))) 512 513 If Not boo Then GoTo Assign_RowSource 514 If IsNull(Me.ListTQ) Then GoTo Assign_RowSource 515 516 sSQL = "SELECT DISTINCT " 517 518 If iListNum = 3 Then 519 sSQL = sSQL & sFld & IIf(Len(sAlias) > 0, " as " & sAlias, "") & " " 520 Else 521 If Nz(Me(sControlnameList).Column(1)) <> "Memo" Then 522 sSQL = sSQL & sFld 523 Else 524 sSQL = sSQL & "Trim(Left(" & sFld & " & space(50),50)) as [" & sFld & "_Left50] " 525 End If 526 End If 527 528 sSQL = sSQL _ 529 & " FROM [" & Me.ListTQ & "]" _ 530 & " WHERE ((" & sFld & ") Is Not Null)" 531 532 If Not IsNull(Me.Date1) Then 533 If Not IsNull(Me.Field1.Column(0)) Then 534 sDateField = Me.Field1.Column(0) 535 sSQL = sSQL & " AND format([" & sDateField & "],""yymm"") =""" _ 536 & Format(Me.Date1, "yymm") & """" 537 538 End If 539 540 End If 541 542 If iListNum = 1 Or iListNum = 4 Then 543 sSQL = sSQL & " ORDER BY " & sFld & " desc" 544 End If 545 546 sSQL = sSQL & ";" 547 548 Assign_RowSource: 549 550 Debug.Print "-- Example " & iListNum & " -- " & Format(Now, "m-d-yy h:nn") 551 Debug.Print sSQL 552 553 Me("Examples" & iListNum) = Null 554 Me("Examples" & iListNum).RowSource = sSQL 555 Me("Examples" & iListNum).Requery 556 557 Me("Source" & iListNum) = sSource 558 If sSQL = "" Then GoTo Proc_Exit 559 560 If Me.FraTQ = 1 Then GoTo Proc_Exit 561 562 'if sourceField was not determined, this will be tablename. 563 If Right(sSource, 1) <> "." Then GoTo Proc_Exit 564 565 If iNum3 > 1 Then 566 Me.Source3 = Null 567 GoTo Proc_Exit 568 End If 569 570 'search SQL string for equation 571 572 sSQL = Me.SQL_ListTQ 573 574 '------------------------------------- HERE get equation '140930 575 576 577 iCountBracket = 0 578 iCountParenthesis = 0 579 iCountSingleQuote = 0 580 iCountDoubleQuote = 0 581 iCount = 0 582 583 iPos2 = InStr(sSQL, " as " & sFieldname) 584 585 If iPos2 = 0 Then 586 iPos2 = InStr(sSQL, " as [" & sFieldname & "]") 587 End If 588 589 If iPos2 = 0 Then 590 iPos2 = InStr(sSQL, " as " & sFld) 591 If iPos2 = 0 Then 592 'this shouldn't happen 593 Me.Source1 = "" 594 GoTo Proc_Exit 595 End If 596 End If 597 598 ' booInDelimited = False 599 For i = (iPos2 - 1) To 1 Step -1 600 sChar = Mid(sSQL, i, 1) 601 Select Case sChar 602 Case "[": iCountBracket = iCountBracket - 1 603 Case "]": iCountBracket = iCountBracket + 1 604 Case "(": iCountParenthesis = iCountParenthesis - 1 605 Case ")": iCountParenthesis = iCountParenthesis + 1 606 Case "'": iCountSingleQuote = iCountSingleQuote + 1 607 Case """": iCountDoubleQuote = iCountDoubleQuote + 1 608 End Select 609 610 iCount = iCountBracket + iCountParenthesis _ 611 + iCountSingleQuote Mod 2 _ 612 + iCountDoubleQuote Mod 2 613 614 If iCount = 0 Then 615 If sChar = "," Then 616 iPos1 = i + 1 617 Me("Source" & iListNum) = Trim(Mid(sSQL, iPos1, iPos2 - iPos1)) 618 Exit Function 619 End If 620 End If 621 ' If InStr("""'", sChar) > 0 Then 622 ' booInDelimited = Not booInDelimited 623 ' Else 624 ' If sChar = "[" Then 625 ' booInDelimited = False 626 ' Else 627 ' If sChar = "]" Then booInDelimited = True 628 ' End If 629 ' End If 630 Next i 631 iPos1 = 8 632 Me("Source" & iListNum) = Trim(Mid(sSQL, iPos1, iPos2 - iPos1)) 633 634 Proc_Exit: 635 Exit Function 636 637 Proc_Err: 638 MsgBox Err.Description, , "ERROR " & Err.Number & " SQL_TQ " & iListNum 639 'press F8 to step through code and debug 640 'remove next line after debugged 641 Stop: Resume 642 Resume Proc_Exit 643 644 End Function |
645 646 647 '------------------------------------------------------ ProcessReport 648 'Private Function ProcessReport() 649 ' 'not used -- serves as an example... 650 ' 'initialize the variable 651 ' mvCrit = Null 652 ' msUserCriteria = "" 653 ' Dim mReport As String 654 ' mReport = "ReportName" 655 ' 656 ' Me.crit = msUserCriteria 657 ' On Error Resume Next 658 ' 659 ' If Len(mvCrit) > 0 Then 660 ' DoCmd.OpenReport mReport, acViewPreview, , mvCrit 661 ' Else 662 ' DoCmd.OpenReport mReport, acViewPreview 663 ' End If 664 ' 665 'End Function 666 667 '------------------------------------------------------ PopCalendarAndDoStuff 668 Private Function PopCalendarAndDoStuff() 669 'double-click event of Date1 or Date2 670 'pop up the calendar and wait for user to close before continuing 671 'the acDialog parameter causes code to STOP 672 'until the user closes the specified form, PickDate 673 DoCmd.OpenForm "PickDate", , , , , acDialog 674 'now you can do other things in your code 675 End Function |
676 677 '------------------------------------------------------ setCritDates 678 Private Function setCritDates(psMethod As String, psDateField As String) As Boolean 679 680 setCritDates = False 681 682 Dim nDate As Date 683 Select Case psMethod 684 685 Case "Month" 686 If Not CheckDates("1") Then Exit Function 687 nDate = Me.Date1 688 Me.Date1 = DateSerial(Year(nDate), Month(nDate), 1) 689 Me.Date2 = DateSerial(Year(nDate), Month(nDate) + 1, 0) 690 691 Case "Months" 692 If Not CheckDates("1") Then Exit Function 693 nDate = Me.Date1 694 Me.Date1 = DateSerial(Year(nDate), Month(nDate), 1) 695 696 If Not IsNull(Me.Date2) Then nDate = Me.Date2 697 Me.Date2 = DateSerial(Year(nDate), Month(nDate) + 1, 0) 698 699 Case "1" 700 If Not CheckDates("1") Then Exit Function 701 702 Case "2" 703 If Not CheckDates("2") Then Exit Function 704 705 Case "optional" 706 If IsNull(Me.Date1) And IsNull(Me.Date2) Then Exit Function 707 708 End Select 709 710 '----------------------------------------------- Dates 711 Dim nDateField 712 If IsMissing(psDateField) Then nDateField = "WorkDate" Else nDateField = psDateField 713 714 715 Select Case True 716 Case (Not IsNull(Me.Date1)) And (Not IsNull(Me.Date2)) 717 mvCrit = (mvCrit + " AND ") _ 718 & "(" & nDateField & " BETWEEN #" & Me.Date1 & "# AND #" & Me.Date2 & "#)" 719 msUserCriteria = msUserCriteria & " " _ 720 & nDateField & ": " & Format(Me.Date1, "m-d-yy") & " to " & Format(Me.Date2, "m-d-yy") 721 722 Case Not IsNull(Me.Date1) 723 mvCrit = (mvCrit + " AND ") 724 mvCrit = "(" & nDateField & " >= #" & Me.Date1 & "#)" 725 msUserCriteria = msUserCriteria & " " _ 726 & nDateField & " >= " & Format(Me.Date1, "m-d-yy") 727 728 Case Not IsNull(Me.Date2) 729 mvCrit = (mvCrit + " AND ") 730 mvCrit = "(" & nDateField & " <= #" & Me.Date2 & "#)" 731 msUserCriteria = msUserCriteria & " " _ 732 & nDateField & " <= " & Format(Me.Date2, "m-d-yy") 733 734 735 736 End Select 737 738 setCritDates = True 739 740 End Function |
741 742 '~~~~~~~~~~~~ 743 744 Private Function CheckDates(Optional ByVal pWhich As String) As Boolean 745 746 CheckDates = False 747 748 Dim mWhich As String 749 If IsMissing(pWhich) Then mWhich = "All" Else mWhich = pWhich 750 751 If mWhich = "2" Then GoTo CheckDates_2 752 753 If IsNull(Me.Date1) Then 754 Me.Date1.SetFocus 755 MsgBox "You must fill out a beginning date", , "Cannot generate report" 756 Exit Function 757 Else 758 If Not IsDate(Me.Date1) Then 759 Me.Date1.SetFocus 760 MsgBox Me.Date1 & " is not a valid date", , "Cannot generate report" 761 Exit Function 762 End If 763 End If 764 765 If mWhich = "1" Then CheckDates = True: Exit Function 766 767 CheckDates_2: 768 If IsNull(Me.Date2) Then 769 Me.Date2.SetFocus 770 MsgBox "You must fill out an ending date", , "Cannot generate report" 771 Exit Function 772 Else 773 If Not IsDate(Me.Date2) Then 774 Me.Date2.SetFocus 775 MsgBox Me.Date2 & " is not a valid date", , "Cannot generate report" 776 Exit Function 777 End If 778 End If 779 CheckDates = True 780 End Function |
781 782 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 783 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 784 785 786 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 787 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ change dates ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 788 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 789 790 Private Function ASDay(pNum As Integer) 791 On Error Resume Next 792 Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1), Day(Me.Date1) + pNum) 793 Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2), Day(Me.Date2) + pNum) 794 End Function |
795 796 Private Function ASMonth(pNum As Integer) 797 On Error Resume Next 798 Me.Date1 = DateSerial(Year(Me.Date1), Month(Me.Date1) + pNum, Day(Me.Date1)) 799 Me.Date2 = DateSerial(Year(Me.Date2), Month(Me.Date2) + pNum, Day(Me.Date2)) 800 End Function |
801 802 Private Function ASYear(pNum As Integer) 803 On Error Resume Next 804 Me.Date1 = DateSerial(Year(Me.Date1) + pNum, Month(Me.Date1), Day(Me.Date1)) 805 Me.Date2 = DateSerial(Year(Me.Date2) + pNum, Month(Me.Date2), Day(Me.Date2)) 806 End Function |
807 808 Private Function FillOneYear() 809 On Error Resume Next 810 Me.Date2 = Date - 1 811 Me.Date1 = DateSerial(Year(Me.Date2) - 1, Month(Me.Date2), Day(Me.Date2)) + 1 812 End Function |
813 814 Private Function FillQuarter(pQtr As Integer) 815 Dim mMonth As Integer, mEndQ As Integer, mYear As Integer 816 mMonth = Month(Date) 817 mEndQ = pQtr * 3 818 If mMonth > mEndQ Then mYear = Year(Date) Else mYear = Year(Date) - 1 819 Me.Date1 = DateSerial(mYear, mEndQ - 2, 1) 820 Me.Date2 = DateSerial(mYear, mEndQ + 1, 1) - 1 821 End Function |
822 823 Private Function FillDate(Optional pDate) 824 On Error Resume Next 825 If IsMissing(pDate) Then pDate = Date 826 Me.Date1 = pDate 827 Me.Date2 = pDate 828 End Function |
829 830 Private Function FillMTD() 831 On Error Resume Next 832 Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 833 Me.Date2 = Date 834 End Function |
835 836 Private Function FillYTD() 837 On Error Resume Next 838 Me.Date1 = DateSerial(Year(Date), 1, 1) 839 Me.Date2 = Date 840 End Function |
841 842 Private Function FillOneWeek() 843 On Error Resume Next 844 Me.Date1 = Date - 6 845 Me.Date2 = Date 846 End Function |
847 848 Private Function FillMonth() 849 On Error Resume Next 850 Me.Date1 = DateSerial(Year(Date), Month(Date), 1) 851 Me.Date2 = DateSerial(Year(Date), Month(Date) + 1, 1) - 1 852 End Function |
853 854 Private Function FillWorkWeek() 855 Dim mDOW As Integer 856 mDOW = Weekday(Date) 857 Me.Date1 = Date - mDOW + 1 858 Me.Date2 = Me.Date1 + 6 859 End Function |
860 861 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 862 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 863 864 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 865 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 866 867 Private Sub EmailTheReport(pReportName As String, pTitle As String, pFrom As String) 868 SetReportFilter pReportName, mvCrit 869 EMailReport pReportName, Me.EmailAddress, pTitle, Me.chkEdit, pFrom 870 MsgBox pTitle & " has been emailed to " & Me.EmailAddress, , "Done with " & pReportName 871 End Sub |
872 873 Private Sub RFTtheReport(pReportName As String, pFilename As String) 874 Dim sFilename As String 875 On Error Resume Next 876 sFilename = CurrentProject.Path & "\RTF" 877 MkDir sFilename 878 On Error GoTo Proc_Err 879 880 sFilename = CurrentProject.Path & "\RTF\" _ 881 & Trim(pReportName & IIf(Len(msUserCriteria) > 0, CorrectFilename(msUserCriteria), "") _ 882 & "_" & Format(Now(), "yymmdd_h_nn")) & ".RTF" 883 884 If Dir(sFilename) <> "" Then 885 Kill sFilename 886 DoEvents 887 End If 888 SetReportFilter pReportName, mvCrit 889 DoCmd.OutputTo acOutputReport, pReportName, acFormatRTF, sFilename 890 'clear the filter 891 ' SetReportFilter pReportName, "" 892 If Me.chkOpen Then Application.FollowHyperlink sFilename 893 894 Proc_Exit: 895 Exit Sub 896 Proc_Err: 897 Select Case Err.Number 898 Case 2501: Resume Proc_Exit 899 Case Else 900 MsgBox Err.Description, , "ERROR " & Err.Number & " RFTtheReport" 901 Resume Proc_Exit 902 Resume 903 End Select 904 End Sub |
905 906 Private Function UnderConstruction() 907 MsgBox "Under Construction", , "Under Construction" 908 End Function |
909 910 911 Private Sub cmdAdd_eMail_Click() 912 'created 10-22-05 913 DoCmd.OpenForm "Email", , , , , acDialog 914 CheckEmailOptions 915 End Sub |
916 917 Private Function CheckEmailOptions() 918 Dim boo As Boolean 919 boo = IIf(IsNull(Me.EmailAddress), False, True) 920 If boo Then 921 Me.fraOutput3.Enabled = True 922 Me.fraOutput = 3 923 Else 924 If Me.fraOutput = 3 Then Me.fraOutput = 1 925 Me.fraOutput3.Enabled = False 926 End If 927 ' BoldMe "fraOutput", 3 928 fraOutput_AfterUpdate 929 End Function |
930 931 Private Sub btnClearEmail_Click() 932 Me.EmailAddress = Null 933 CheckEmailOptions 934 End Sub |
935 936 Private Function ClearList(ByVal pControlname As String) 937 Dim varItem As Variant 938 For Each varItem In Me(pControlname).ItemsSelected 939 Me(pControlname).Selected(varItem) = False 940 Next varItem 941 End Function |
942 943 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 944 '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 945 946 '------------------------------------------------------ cmdClose_Click 947 Private Function CloseMeMe() 948 DoCmd.Close acForm, Me.Name, acSaveNo 949 End Function |
950 951 '------------------------------------------------------ ResetData 952 Private Function ResetData() 953 '5-15-06 954 Me.btn1.SetFocus 955 956 Me.ListTQ = Null 957 Dim i As Integer, varItem As Variant 958 959 Me.CalTitle = "" 960 961 For i = 1 To 4 962 963 With Me("field" & i) 964 965 If i = 3 Then 966 ClearList "Field3" 967 Else 968 .Value = Null 969 End If 970 971 .RowSource = "" 972 .Requery 973 974 End With 975 976 With Me("Examples" & i) 977 .RowSource = "" 978 .Requery 979 .Value = Null 980 End With 981 982 Me("Source" & i) = Null 983 984 Next i 985 986 987 Me.FormatCodes = "" 988 989 Me.label_FooterCalc1.Visible = False 990 Me.label_FooterCalc2.Visible = False 991 Me.prompt_FooterCalc1.Visible = False 992 Me.prompt_FooterCalc2.Visible = False 993 Me.label_Footer1.Visible = False 994 Me.prompt_Footer1.Visible = False 995 Me.label_Footer2.Visible = False 996 Me.prompt_Footer2.Visible = False 997 Me.label_Footer3.Visible = False 998 Me.prompt_Footer3.Visible = False 999 1,000 Me.Label_fraSumcount.Visible = False 1,001 Me.fraSumcount.Enabled = False 1,002 Me.fraSumcount = 3 1,003 1,004 Me.Field3eqn = Null 1,005 Me.Field3Alias = Null 1,006 1,007 1,008 End Function |
1,009 1,010 '------------------------------------------------------ fraOutput_AfterUpdate 1,011 Private Sub fraOutput_AfterUpdate() 1,012 Dim nColor As Long _ 1,013 , i As Integer _ 1,014 , boo As Boolean 1,015 1,016 For i = 1 To 3 1,017 If i = Me.fraOutput Then boo = True Else boo = False 1,018 Me("label_fraOutput" & Format(i, "0")).FontBold = boo 1,019 Next i 1,020 1,021 Select Case Me.fraOutput 1,022 Case 1 'screen 1,023 nColor = 8388608 1,024 Case 2 'snap 1,025 nColor = 128 1,026 Case 3 ' email 1,027 nColor = 13056 1,028 End Select 1,029 1,030 For i = 1 To gNUMREPORTS 1,031 Me("btn" & i).BackColor = nColor 1,032 Next i 1,033 1,034 End Sub |
1,035 1,036 1,037 '------------------------------------------------------ Edit_TQ 1,038 Private Function Edit_TQ() 1,039 'on me.ListTQ double-click 1,040 If Me.FraTQ = 2 Then 1,041 Debug.Print "--- SQL for " & Me.ListTQ & " --- " & Format(Now(), "ddd m-d-yy j:nn") 1,042 Debug.Print Nz(CurrentDb.QueryDefs(Me.[ListTQ]).SQL) 1,043 End If 1,044 1,045 On Error Resume Next 1,046 If Me.FraTQ = 1 Then 1,047 DoCmd.OpenTable Me.ListTQ 1,048 Else 1,049 DoCmd.OpenQuery Me.ListTQ, acViewDesign 1,050 End If 1,051 End Function |
1,052 1,053 '------------------------------------------------------ 1,054 1,055 1,056 '------------------------------------------------------ NewFooterText 1,057 Private Function NewFooterText(pWhich) 1,058 Dim sText As String, sNewText As String 1,059 sText = Trim(Nz(Me("label_Footer" & Format(pWhich, "0")).Caption)) 1,060 sNewText = InputBox("Enter new caption:", "Change Report Footer Text", sText) 1,061 If sNewText <> "" Then 1,062 Me("label_Footer" & Format(pWhich, "0")).Caption = sNewText 1,063 End If 1,064 End Function |
1,065 1,066 Private Sub FraTQ_AfterUpdate() 1,067 Call SQL_TQ(Me.FraTQ) 1,068 End Sub |
1,069 1,070 Private Sub label_Footer1_DblClick(Cancel As Integer) 1,071 Call NewFooterText(1) 1,072 End Sub |
1,073 1,074 Private Sub label_Footer2_DblClick(Cancel As Integer) 1,075 Call NewFooterText(2) 1,076 End Sub |
1,077 1,078 Private Sub label_Footer3_DblClick(Cancel As Integer) 1,079 Call NewFooterText(3) 1,080 End Sub |
1,081 1,082 Private Sub label_Footer4_DblClick(Cancel As Integer) 1,083 Call NewFooterText(4) 1,084 End Sub |
1,085 1,086 Private Sub Label_writtenBy_Click() 1,087 '140930 1,088 Application.FollowHyperlink _ 1,089 "mailto: strive4peace2012@yahoo.com?subject= HTML Calendar comment" 1,090 End Sub |
1,091 1,092 Private Sub ListTQ_AfterUpdate() 1,093 '140929 1,094 Call SQL_Fields 1,095 End Sub |
1,096 1,097 Private Sub ListTQ_DblClick(Cancel As Integer) 1,098 '140929 1,099 Call Edit_TQ 1,100 End Sub |
1,101 1,102 1,103 '------------------------------------------------------ Report_Calendar 1,104 Private Function Report_Calendar() 1,105 1,106 On Error GoTo Proc_Err 1,107 1,108 'crystal, strive4peace 1,109 ' 060516... 140929 1,110 1,111 'CALLS 1,112 ' MkDir 1,113 ' Create_HTMLCalendar 1,114 1,115 Dim varItem As Variant 1,116 Dim nDate As Date _ 1,117 , sFilename As String _ 1,118 , sPath As String 1,119 1,120 If IsNull(Me.ListTQ) Then 1,121 MsgBox "You must choose a TABLE or QUERY (data source)", , "Aborting Calendar" 1,122 Exit Function 1,123 End If 1,124 1,125 If IsNull(Me.Field1) Then 1,126 MsgBox "You must choose a DATE FIELD for the calendar", , "Aborting Calendar..." 1,127 Me.Field1.SetFocus 1,128 Exit Function 1,129 End If 1,130 1,131 Debug.Print Me.Field3.Value '140929 1,132 1,133 If (IsNull(Me.Field2.Column(0)) And IsNull(Me.Field3.Column(0)) And IsNull(Me.Field4.Column(0))) Then '140929 added outer ( ) 1,134 MsgBox "You must select something to display on the calendar", , "Aborting Calendar..." 1,135 Exit Function 1,136 End If 1,137 1,138 If IsNull(Me.Date1) Then 1,139 If IsNull(Me.Date2) Then 1,140 MsgBox "You must select a DATE in the month for the calendar", , "Aborting Calendar..." 1,141 Exit Function 1,142 End If 1,143 Me.Date1 = Me.Date2 1,144 Else 1,145 If IsNull(Me.Date2) Then Me.Date2 = Me.Date1 1,146 End If 1,147 1,148 msUserCriteria = "" 1,149 mvCrit = Null 1,150 1,151 ' If Not setCritDates("month", Me.Field1) Then 1,152 ' MsgBox "Cannot determine month to print calendar -- pick a date", , "Aborting Calendar..." 1,153 ' Exit Function 1,154 ' End If 1,155 1,156 ' msUserCriteria = "" 1,157 ' mvCrit = null 1,158 1,159 'create filename 1,160 sPath = CurrentProject.Path & "\web_Calendars" 1,161 On Error Resume Next 1,162 Call MkDir(sPath) 1,163 DoEvents 1,164 On Error GoTo Proc_Err 1,165 1,166 nDate = Me.Date1 1,167 1,168 Do 1,169 sFilename = Trim(sPath & "\c_" _ 1,170 & Trim(Format(nDate, "yy-mm")) _ 1,171 & "_" & Trim(Me.CalTitle) _ 1,172 & IIf(IsNull(Me.Field3Alias), "", "_" & Me.Field3Alias)) & ".html" 1,173 1,174 'Debug.Print sFilename 1,175 'Stop 1,176 'IIf(IsNull(Me.Field4.Column(0)), 1, Me.fraSumcount) 1,177 1,178 If Not Create_HTMLCalendar(sFilename, _ 1,179 nDate, _ 1,180 Nz(Me.CalTitle, IIf(IsNull(Me.Field3Alias), "", " " & Me.Field3Alias)), _ 1,181 mvCrit, _ 1,182 "crit", _ 1,183 Me.ListTQ, _ 1,184 Me.Field1.Column(0), _ 1,185 Nz(Me.Field2.Column(0), ""), _ 1,186 Nz(Me.Field3eqn, ""), _ 1,187 Nz(Me.Field4.Column(0), ""), _ 1,188 Nz(Me.Field4.Column(0), 0), _ 1,189 Nz(Me.FormatCodes), _ 1,190 IIf(Not Me.label_Footer1.Visible, "", Trim(Nz(Me.label_Footer1.Caption))), _ 1,191 IIf(Not Me.label_Footer1.Visible, "", Trim(Nz(Me.label_Footer2.Caption))), _ 1,192 Trim(Nz(Me.label_Footer3.Caption)), _ 1,193 Trim(Nz(Me.label_Footer4.Caption)), _ 1,194 IIf(IsNull(Me.Color3), "008080", Me.Color3), _ 1,195 IIf(IsNull(Me.Color4), "008000", Me.Color4), _ 1,196 IIf(IsNull(Me.Color3B), "FF6347", Me.Color3B) _ 1,197 ) Then 1,198 MsgBox "CALENDAR CREATION WAS NOT SUCCESSFUL " _ 1,199 & " for " & Format(nDate, "mmm-yyyy"), , Format(nDate, "yymm") & " Not Successful" 1,200 GoTo Cal_NextMonth 1,201 End If 1,202 1,203 1,204 If Me.fraOutput = 3 Then 1,205 'email calendar 1,206 If IsNull(Me.EmailAddress) Then 1,207 MsgBox "You must select an email address to email a calendar", , "Need email address" 1,208 Else 1,209 MsgBox "Email function is under construction", , "Email under construction" 1,210 'add code 1,211 End If 1,212 1,213 GoTo Proc_Exit 1,214 1,215 Else 1,216 If Nz(Me.chkOpenBrowser, False) = True Then 1,217 Application.FollowHyperlink sFilename 1,218 DoEvents 1,219 End If 1,220 End If 1,221 1,222 Cal_NextMonth: 1,223 'go to next month 1,224 nDate = DateSerial(Year(nDate), Month(nDate) + 1, 1) 1,225 1,226 Loop Until Format(nDate, "yymm") > Format(Me.Date2, "yymm") 1,227 1,228 Proc_Exit: 1,229 Exit Function 1,230 1,231 Proc_Err: 1,232 MsgBox Err.Description, , "ERROR " & Err.Number & " Report_Calendar" 1,233 Stop 1,234 Resume 1,235 1,236 End Function |
1,237 1,238 1,239 '========================================================== 1,240 ' below here could be in a general modules 1,241 ' 1,242 'Crystal_GenerateHTML 1,243 1,244 'crystal 1,245 'strive4peace2004@yahoo.ca 1,246 'modified 4-2-06 1,247 '5-16-06 calendar 1,248 1,249 'NEEDS REFERENCES 1,250 'Microsoft DAO 1,251 1,252 1,253 'CALLS 1,254 1,255 'html_StartTime 1,256 'MkDir (VBA.FileSystem) 1,257 'html_EndTime 1,258 1,259 'WriteHTMLheader 1,260 'WriteHTMLfooter 1,261 1,262 1,263 1,264 '------------------------------------------------- Create_HTMLCalendar 1,265 Function Create_HTMLCalendar( _ 1,266 psPathFile As String, _ 1,267 pnDate As Date, _ 1,268 psCalTitle As String, _ 1,269 pvCrit As Variant, _ 1,270 psFriendlyCrit As String, _ 1,271 psTableOrQueryName As String, _ 1,272 psFldName_Date As String, _ 1,273 psFldName_ID As String, _ 1,274 psFldName_Text As String, _ 1,275 psFldName_Calc As String, _ 1,276 Optional psFldName_Calc_operation As Integer = 0, _ 1,277 Optional psFormatCode As String, _ 1,278 Optional psFooterAfterCountID As String, _ 1,279 Optional psFooterBeforeCalc As String, _ 1,280 Optional psFooterBeforeDays As String, _ 1,281 Optional psFooterAfterDays As String, _ 1,282 Optional psColor3 As String = "4682B4", _ 1,283 Optional psColor4 As String = "008000", _ 1,284 Optional psColor3B As String = "FF6347" _ 1,285 ) As Boolean 1,286 1,287 'CALLS 1,288 'html_StartTime 1,289 'MkDir 1,290 'html_EndTime 1,291 'WriteHTMLheader 1,292 'WriteHTMLfooter 1,293 'Shell "C:\Program Files\Internet Explorer\iexplore.exe " & sFilename, vbMaximizedFocus 1,294 1,295 'assume calendar was not successful 1,296 Create_HTMLCalendar = False 1,297 1,298 'time how long it takes to do thing 1,299 Call html_StartTime 1,300 1,301 'set up error handler 1,302 On Error GoTo Proc_Err 1,303 1,304 'dimension variables 1,305 Dim iDOW1 As Integer _ 1,306 , iDOW2 As Integer _ 1,307 , nDate1 As Date _ 1,308 , nDate2 As Date _ 1,309 , nDate As Date 1,310 Dim nNumDaysWithData As Integer _ 1,311 , mCalDate As Date _ 1,312 , mDay As Integer 1,313 Dim iColWidth _ 1,314 , mTotalAmount As Currency _ 1,315 , sColor As String 1,316 1,317 Dim nCountIDs As Long _ 1,318 , nCountDays As Long _ 1,319 , nCountID As Long _ 1,320 , curSumAmount As Currency _ 1,321 , nLastDate As Date 1,322 1,323 Dim iFileNumber As Integer _ 1,324 , sSQL As String _ 1,325 , mOperation As Integer 1,326 Dim iCalDay As Integer _ 1,327 , iCol As Integer _ 1,328 , iRow As Integer 1,329 1,330 Dim db As DAO.Database _ 1,331 , rs As DAO.Recordset 1,332 1,333 nDate1 = DateSerial(Year(pnDate), Month(pnDate), 1) 1,334 nDate2 = DateSerial(Year(pnDate), Month(pnDate) + 1, 0) 1,335 1,336 iDOW1 = Weekday(nDate1) 1,337 iDOW2 = Weekday(nDate2) 1,338 1,339 ' nNuiRowsSQL = CInt((Day(nDate2) + iDOW1 - 1) / 7 - 0.5) + 1 1,340 nNumDaysWithData = 0 1,341 1,342 iColWidth = 130 1,343 mTotalAmount = 0 1,344 1,345 'determine Sum/count/Each (1/2/3) 1,346 If Len(psFldName_Calc) = 0 Then 1,347 mOperation = 0 1,348 Else 1,349 mOperation = psFldName_Calc_operation 1,350 End If 1,351 1,352 '--------------------- construct SQL for calendar day values 1,353 1,354 sSQL = "SELECT DateValue([" & psFldName_Date & "]) AS CalDate" 1,355 1,356 If Len(Trim(psFldName_ID)) > 0 And Len(Trim(psFldName_Text)) > 0 Then 1,357 sSQL = sSQL & ", [" & psFldName_ID & "] as CalID" 1,358 Else 1,359 sSQL = sSQL & ", 0 as CalID" 1,360 End If 1,361 1,362 If Len(Trim(psFldName_Text)) > 0 Then 1,363 'if field3 does not have any brackets, enclose it in brackets 1,364 'field may be an equation... 1,365 If InStr(psFldName_Text, "[") > 0 Then 1,366 sSQL = sSQL & ", " & psFldName_Text & " as CalText" 1,367 Else 1,368 sSQL = sSQL & ", [" & psFldName_Text & "] as CalText" 1,369 End If 1,370 Else 1,371 sSQL = sSQL & ", """" as CalText" 1,372 End If 1,373 1,374 Select Case mOperation 1,375 Case 0 1,376 sSQL = sSQL & ", cCur(0) as CalAmount" 1,377 Case 1 1,378 If InStr(psFldName_Calc, "nz") = 0 Then 1,379 sSQL = sSQL & ", SUM(nz([" & psFldName_Calc & "])) as CalAmount" 1,380 Else 1,381 sSQL = sSQL & ", SUM(" & psFldName_Calc & ") as CalAmount" 1,382 End If 1,383 Case 2 1,384 If InStr(psFldName_Calc, "nz") = 0 Then 1,385 sSQL = sSQL & ", COUNT(nz([" & psFldName_Calc & "])) as CalAmount" 1,386 Else 1,387 sSQL = sSQL & ", COUNT(" & psFldName_Calc & ") as CalAmount" 1,388 End If 1,389 Case 3 1,390 If InStr(psFldName_Calc, "[") = 0 Then 1,391 sSQL = sSQL & ", [" & psFldName_Calc & "] as CalAmount" 1,392 Else 1,393 sSQL = sSQL & ", " & psFldName_Calc & " as CalAmount" 1,394 End If 1,395 End Select 1,396 1,397 sSQL = sSQL & " FROM [" & psTableOrQueryName & "] " 1,398 1,399 sSQL = sSQL & " WHERE format(nz([" & psFldName_Date & "]),""yymm"") = '" & Format(pnDate, "yymm") & "' " 1,400 If Len(pvCrit) > 0 Then 1,401 sSQL = sSQL & " AND " & pvCrit 1,402 End If 1,403 1,404 Select Case mOperation 1,405 Case 0, 1, 2 1,406 sSQL = sSQL & " GROUP BY DateValue([" & psFldName_Date & "])" 1,407 If Len(psFldName_ID) > 0 And Len(Trim(psFldName_Text)) > 0 Then 1,408 sSQL = sSQL & ", [" & psFldName_ID & "]" 1,409 End If 1,410 If Len(psFldName_Text) > 0 Then 1,411 If InStr(psFldName_Text, "[") > 0 Then 1,412 sSQL = sSQL & ", " & psFldName_Text 1,413 Else 1,414 sSQL = sSQL & ", [" & psFldName_Text & "]" 1,415 End If 1,416 End If 1,417 End Select 1,418 1,419 If InStr(sSQL, "GROUP BY") = 0 Then 1,420 sSQL = sSQL & " ORDER BY [" & psFldName_Date & "]" 1,421 If Len(Trim(psFldName_ID)) > 0 And Len(Trim(psFldName_Text)) > 0 Then _ 1,422 sSQL = sSQL & ", [" & psFldName_ID & "]" 1,423 If Len(Trim(psFldName_Text)) > 0 Then _ 1,424 sSQL = sSQL & ", " & IIf(InStr(psFldName_Text, "[") > 0, psFldName_Text, "[" & psFldName_Text & "]") 1,425 1,426 End If 1,427 1,428 sSQL = sSQL & ";" 1,429 1,430 Debug.Print " ---CALENDAR---" & Now() 1,431 Debug.Print sSQL 1,432 1,433 Set db = CurrentDb 1,434 Set rs = db.OpenRecordset(sSQL, dbOpenDynaset) 1,435 1,436 With rs 1,437 If .EOF Then 1,438 ' MsgBox "No records matching specified criteria for " & Format(pnDate, "mmm-yy"), , "Aborting Calendar Report" 1,439 .Close 1,440 Set rs = Nothing 1,441 Call html_EndTime 1,442 Exit Function 1,443 End If 1,444 .MoveFirst 1,445 1,446 '************************************************************************************* 1,447 '-------------------------------------------------------------------- create web page 1,448 1,449 iFileNumber = FreeFile 1,450 1,451 On Error Resume Next 1,452 Close #iFileNumber 1,453 If Dir(psPathFile) <> "" Then 1,454 Kill psPathFile 1,455 ' DoEvents: DoCmd.Hourglass True 1,456 End If 1,457 1,458 '-------------------------------------------------------------------- ~header 1,459 On Error GoTo Proc_Err 1,460 Open psPathFile For Output As #iFileNumber 1,461 WriteHTMLheader iFileNumber, Format(!CalDate, "mmmm yyyy"), psCalTitle 1,462 1,463 ' DoEvents: DoCmd.Hourglass True 1,464 1,465 'define table 1,466 Print #iFileNumber, " |
1,770 1,771 '------------------------------------------------- WriteHTMLheader 1,772 Function WriteHTMLheader(iFileNumber As Integer, _ 1,773 pTitleMain As String, _ 1,774 pTitleKicker As String _ 1,775 ) 1,776 1,777 Print #iFileNumber, "" 1,778 Print #iFileNumber, "" 1,779 Print #iFileNumber, " |
1,809 1,810 1,811 '------------------------------------------------- WriteHTMLfooter 1,812 Function WriteHTMLfooter( _ 1,813 iFileNumber As Integer _ 1,814 , Optional pBooPrintBy As Boolean) 1,815 1,816 Print #iFileNumber, "" 1,817 Print #iFileNumber, " |