1: 2: Sub AddShareIfNeeded (SharePath$, ShareFile$) 3: On Error GoTo ShareError 4: 5: fh% = FreeFile 6: Open "C:\AUTOEXEC.BAT" For Input As fh% 7: 8: fFound% = 0 9: While Not fFound% And Not EOF(fh%) 10: Line Input #fh%, Temp1$ 11: If InStr(1, UCase$(Temp1$), "REM") = 0 And InStr(1, Temp1$, ";") = 0 And InStr(1, UCase$(Temp1$), "SHARE") > 0 Then 12: fFound% = True 13: End If 14: Wend 15: 16: Close #fh% 17: 18: If Not fFound% Then 19: MsgBox "Please add <PATH>SHARE.EXE /L:500 to your AUTOEXEC.BAT" 20: End If 21: 22: Exit Sub 23: ShareError: 24: Close #fh%, #fh2% 25: Exit Sub 26: End Sub 27: 28: '------------------------------------------------------- 29: ' Centers the passed form just above center on the screen 30: '------------------------------------------------------- 31: Sub CenterForm (x As Form) 32: 33: Screen.MousePointer = 11 34: x.Top = (Screen.Height * .85) / 2 - x.Height / 2 35: x.Left = Screen.Width / 2 - x.Width / 2 36: Screen.MousePointer = 0 37: 38: End Sub 39: 40: Sub ConcatSplitFiles (firstfile$, cSplit%) 41: Dim x%, fh1%, fh2%, outfile$, outfileLen&, CopyLeftOver&, CopyChunk#, filevar$ 42: Dim iFileMax%, iFile%, y% 43: 44: For x% = 2 To cSplit% 45: 46: fh1% = FreeFile 47: Open Left$(firstfile$, Len(firstfile$) - 1) + Format$(1) For Binary As fh1% 48: 49: fh2% = FreeFile 50: outfile$ = Left$(firstfile$, Len(firstfile$) - 1) + Format$(x%) 51: Open outfile$ For Binary As fh2% 52: 53: ' Goto the end of file (plus one bytes) to start writing data 54: Seek #fh1%, LOF(fh1%) + 1 55: 56: outfileLen& = LOF(fh2%) 57: CopyLeftOver& = outfileLen& Mod 10 58: CopyChunk# = (outfileLen& - CopyLeftOver&) / 10 59: filevar$ = String$(CopyLeftOver&, 32) 60: Get #fh2%, , filevar$ 61: Put #fh1%, , filevar$ 62: filevar$ = String$(CopyChunk#, 32) 63: iFileMax% = 10 64: For iFile% = 1 To iFileMax% 65: Get #fh2%, , filevar$ 66: Put #fh1%, , filevar$ 67: Next iFile% 68: 69: Close fh1%, fh2% 70: y% = SetTime(outfile$, firstfile$) 71: Kill outfile$ 72: 73: Next x% 74: 75: FileCopy Left$(firstfile$, Len(firstfile$) - 1) + Format$(1), firstfile$ 76: Kill Left$(firstfile$, Len(firstfile$) - 1) + Format$(1) 77: End Sub 78: 79: '--------------------------------------------------------------- 80: ' Copies file SrcFilename from SourcePath to DestinationPath. 81: ' 82: ' Returns 0 if it could not find the file, or other runtime 83: ' error occurs. Otherwise, returns true. 84: ' 85: ' If the source file is older, the function returns success (-1) 86: ' even though no file was copied, since no error occurred. 87: '--------------------------------------------------------------- 88: Function CopyFile (ByVal SourcePath As String, ByVal DestinationPath As String, ByVal SrcFilename As String, ByVal DestFileName As String) 89: ' ----- VerInstallFile() flags ----- 90: Const VIFF_FORCEINSTALL% = &H1, VIFF_DONTDELETEOLD% = &H2 91: Const OF_DELETE% = &H200 92: Const VIF_TEMPFILE& = &H1 93: Const VIF_MISMATCH& = &H2 94: Const VIF_SRCOLD& = &H4 95: 96: Const VIF_DIFFLANG& = &H8 97: Const VIF_DIFFCODEPG& = &H10 98: Const VIF_DIFFTYPE& = &H20 99: Const VIF_WRITEPROT& = &H40 100: Const VIF_FILEINUSE& = &H80 101: Const VIF_OUTOFSPACE& = &H100 102: Const VIF_ACCESSVIOLATION& = &H200 103: Const VIF_SHARINGVIOLATION = &H400 104: Const VIF_CANNOTCREATE = &H800 105: Const VIF_CANNOTDELETE = &H1000 106: Const VIF_CANNOTRENAME = &H2000 107: Const VIF_CANNOTDELETECUR = &H4000 108: Const VIF_OUTOFMEMORY = &H8000 109: 110: Const VIF_CANNOTREADSRC = &H10000 111: Const VIF_CANNOTREADDST = &H20000 112: 113: Const VIF_BUFFTOOSMALL = &H40000 114: Dim TmpOFStruct As OFStruct 115: On Error GoTo ErrorCopy 116: 117: Screen.MousePointer = 11 118: 119: '-------------------------------------- 120: ' Add ending \ symbols to path variables 121: '-------------------------------------- 122: If Right$(SourcePath$, 1) <> "\" Then 123: SourcePath$ = SourcePath$ + "\" 124: End If 125: If Right$(DestinationPath$, 1) <> "\" Then 126: DestinationPath$ = DestinationPath$ + "\" 127: End If 128: 129: '---------------------------- 130: ' Update status dialog info 131: '---------------------------- 132: Statusdlg.Label1.Caption = "Source file: " + Chr$(10) + Chr$(13) + UCase$(SourcePath$ + SrcFilename$) 133: Statusdlg.Label1.Refresh 134: Statusdlg.Label2.Caption = "Destination file: " + Chr$(10) + Chr$(13) + UCase$(DestinationPath$ + DestFileName$) 135: Statusdlg.Label2.Refresh 136: 137: '----------------------------------------- 138: ' Check the validity of the path and file 139: '----------------------------------------- 140: CheckForExist: 141: If Not FileExists(SourcePath$ + SrcFilename$) Then 142: Screen.MousePointer = 0 143: x% = MsgBox("Error occurred while attempting to copy file. Could not locate file: """ + SourcePath$ + SrcFilename$ + """", 34, "SETUP") 144: Screen.MousePointer = 11 145: If x% = 3 Then 146: CopyFile = False 147: ElseIf x% = 4 Then 148: GoTo CheckForExist 149: ElseIf x% = 5 Then 150: GoTo SkipThisFile 151: End If 152: Else 153: '------------------------------------------------- 154: ' VerInstallFile installs the file. We need to initialize 155: ' some arguments for the temp file that is created by the call 156: '------------------------------------------------- 157: TryToCopyAgain: 158: CurrDir$ = String$(255, 0) 159: TmpFile$ = String$(255, 0) 160: lpwTempFileLen% = 255 161: InFileVer$ = GetFileVersion(SourcePath$ + SrcFilename$) 162: OutFileVer$ = GetFileVersion(DestinationPath$ + DestFileName$) 163: 164: ' Install if no version info is available 165: If Len(InFileVer$) <> 0 And Len(OutFileVer$) <> 0 Then 166: ' Don't install older or same version of file 167: If InFileVer$ <= OutFileVer$ Then 168: UpdateStatus GetFileSize(SourcePath$ + SrcFilename$) 169: CopyFile = True 170: Exit Function 171: End If 172: End If 173: 174: Result& = VerInstallFile&(0, SrcFilename$, DestFileName$, SourcePath$, DestinationPath$, CurrDir$, TmpFile$, lpwTempFileLen%) 175: 176: '-------------------------------------------- 177: ' After copying, update the installation meter 178: '--------------------------------------------- 179: 180: S$ = DestinationPath$ 181: If Right$(S$, 1) <> "\" Then S$ = S$ + "\" 182: S$ = S$ + DestFileName$ 183: If Not TryAgain% Then UpdateStatus GetFileSize(S$) 184: 185: '-------------------------------- 186: ' There are many return values that you can test for. 187: ' The constants are listed above. 188: ' The following lines of code return will set the Function to 189: ' True if the VerInstallFile call was successful. 190: ' 191: ' If the call was unsuccessful due to a different language on the 192: ' users machine, VerInstallFile is called again to force installation. 193: ' You can change this to not install if you choose. 194: ' Be careful about using FORCEINSTALL. Other flags could be 195: ' set which indicate that this file should not be overridden. 196: ' 197: ' Under any other circumstance, the tempfile created by VerInstallFile 198: ' is removed using OpenFile and the CopyFile function returns false. 199: '-------------------------------------------------------- 200: 201: If Result& = 0 Or (Result& And VIF_SRCOLD&) = VIF_SRCOLD& Then 202: CopyFile = True 203: ElseIf (Result& And VIF_DIFFLANG&) = VIF_DIFFLANG& Then 204: Result& = VerInstallFile&(VIFF_FORCEINSTALL%, SrcFilename$, DestFileName$, SourcePath$, DestinationPath$, CurrDir$, TmpFile$, lpwTempFileLen%) 205: CopyFile = True 206: ElseIf (Result& And VIF_WRITEPROT&) = VIF_WRITEPROT& Then 207: Result& = VerInstallFile&(VIFF_FORCEINSTALL%, SrcFilename$, DestFileName$, SourcePath$, winSysDir$ + "\", CurrDir$, TmpFile$, lpwTempFileLen%) 208: CopyFile = True 209: ElseIf (Result& And VIF_CANNOTREADSRC) = VIF_CANNOTREADSRC Then 210: ' VerInstallFile does will not handle compressed files that have been split. 211: ' Use VB's FileCopy stmt 212: FileCopy SourcePath$ + SrcFilename$, DestinationPath$ + DestFileName$ 213: CopyFile = True 214: Else 215: Screen.MousePointer = 0 216: If (Result& And VIF_FILEINUSE&) = VIF_FILEINUSE& Then 217: x% = MsgBox(DestFileName$ & " is in use. Please close all applications and re-attempt Setup.", 34) 218: If x% = 3 Then 219: CopyFile = False 220: ElseIf x% = 4 Then 221: TryAgain% = True 222: GoTo TryToCopyAgain 223: ElseIf x% = 5 Then 224: CopyFile = True 225: GoTo SkipThisFile 226: End If 227: Else 228: MsgBox DestFileName$ & " could not be installed." 229: CopyFile = False 230: End If 231: Screen.MousePointer = 11 232: End If 233: 234: If (Result& And VIF_TEMPFILE&) = VIF_TEMPFILE& Then copyresult% = OpenFile(TmpFile$, TmpOFStruct, OF_DELETE%) 235: Screen.MousePointer = 0 236: Exit Function 237: End If 238: 239: SkipThisFile: 240: Exit Function 241: ErrorCopy: 242: CopyFile = False 243: Screen.MousePointer = 0 244: Exit Function 245: 246: End Function 247: 248: '--------------------------------------------- 249: ' Create the path contained in DestPath$ 250: ' First char must be drive letter, followed by 251: ' a ":\" followed by the path, if any. 252: '--------------------------------------------- 253: Function CreatePath (ByVal DestPath$) As Integer 254: Screen.MousePointer = 11 255: 256: '--------------------------------------------- 257: ' Add slash to end of path if not there already 258: '--------------------------------------------- 259: If Right$(DestPath$, 1) <> "\" Then 260: DestPath$ = DestPath$ + "\" 261: End If 262: 263: 264: '----------------------------------- 265: ' Change to the root dir of the drive 266: '----------------------------------- 267: On Error Resume Next 268: ChDrive DestPath$ 269: If Err <> 0 Then GoTo errorOut 270: ChDir "\" 271: 272: '------------------------------------------------- 273: ' Attempt to make each directory, then change to it 274: '------------------------------------------------- 275: BackPos = 3 276: forePos = InStr(4, DestPath$, "\") 277: Do While forePos <> 0 278: temp$ = Mid$(DestPath$, BackPos + 1, forePos - BackPos - 1) 279: 280: Err = 0 281: MkDir temp$ 282: If Err <> 0 And Err <> 75 Then GoTo errorOut 283: 284: Err = 0 285: ChDir temp$ 286: If Err <> 0 Then GoTo errorOut 287: 288: BackPos = forePos 289: forePos = InStr(BackPos + 1, DestPath$, "\") 290: Loop 291: 292: CreatePath = True 293: Screen.MousePointer = 0 294: Exit Function 295: 296: errorOut: 297: MsgBox "Error While Attempting to Create Directories on Destination Drive.", 48, "SETUP" 298: CreatePath = False 299: Screen.MousePointer = 0 300: 301: End Function 302: 303: '------------------------------------------------------------- 304: ' Procedure: CreateProgManGroup 305: ' Arguments: X The Form where a Label1 exist 306: ' GroupName$ A string that contains the group name 307: ' GroupPath$ A string that contains the group file 308: ' name ie 'myapp.grp' 309: '------------------------------------------------------------- 310: Sub CreateProgManGroup (x As Form, GroupName$, GroupPath$) 311: 312: Screen.MousePointer = 11 313: 314: '---------------------------------------------------------------------- 315: ' Windows requires DDE in order to create a program group and item. 316: ' Here, a Visual Basic label control is used to generate the DDE messages 317: '---------------------------------------------------------------------- 318: On Error Resume Next 319: 320: 321: '-------------------------------- 322: ' Set LinkTopic to PROGRAM MANAGER 323: '-------------------------------- 324: x.Label1.LinkTopic = "ProgMan|Progman" 325: x.Label1.LinkMode = 2 326: For i% = 1 To 10 ' Loop to ensure that there is enough time to 327: z% = DoEvents() ' process DDE Execute. This is redundant but needed 328: Next ' for debug windows. 329: x.Label1.LinkTimeout = 100 330: 331: 332: '--------------------- 333: ' Create program group 334: '--------------------- 335: x.Label1.LinkExecute "[CreateGroup(" + GroupName$ + Chr$(44) + GroupPath$ + ")]" 336: 337: 338: '----------------- 339: ' Reset properties 340: '----------------- 341: x.Label1.LinkTimeout = 50 342: x.Label1.LinkMode = 0 343: 344: Screen.MousePointer = 0 345: End Sub 346: 347: '---------------------------------------------------------- 348: ' Procedure: CreateProgManItem 349: ' 350: ' Arguments: X The form where Label1 exists 351: ' 352: ' CmdLine$ A string that contains the command 353: ' line for the item/icon. 354: ' ie 'c:\myapp\setup.exe' 355: ' 356: ' IconTitle$ A string that contains the item's 357: ' caption 358: '---------------------------------------------------------- 359: Sub CreateProgManItem (x As Form, CmdLine$, IconTitle$) 360: 361: Screen.MousePointer = 11 362: 363: '---------------------------------------------------------------------- 364: ' Windows requires DDE in order to create a program group and item. 365: ' Here, a Visual Basic label control is used to generate the DDE messages 366: '---------------------------------------------------------------------- 367: On Error Resume Next 368: 369: 370: '--------------------------------- 371: ' Set LinkTopic to PROGRAM MANAGER 372: '--------------------------------- 373: x.Label1.LinkTopic = "ProgMan|Progman" 374: x.Label1.LinkMode = 2 375: For i% = 1 To 10 ' Loop to ensure that there is enough time to 376: z% = DoEvents() ' process DDE Execute. This is redundant but needed 377: Next ' for debug windows. 378: x.Label1.LinkTimeout = 100 379: 380: 381: '------------------------------------------------ 382: ' Create Program Item, one of the icons to launch 383: ' an application from Program Manager 384: '------------------------------------------------ 385: If gfWin31% Then 386: ' Win 3.1 has a ReplaceItem, which will allow us to replace existing icons 387: x.Label1.LinkExecute "[ReplaceItem(" + IconTitle$ + ")]" 388: End If 389: x.Label1.LinkExecute "[AddItem(" + CmdLine$ + Chr$(44) + IconTitle$ + Chr$(44) + ",,)]" 390: x.Label1.LinkExecute "[ShowGroup(groupname, 1)]" ' This will ensure that Program Manager does not 391: ' have a Maximized group, which causes problem in RestoreProgMan 392: 393: '----------------- 394: ' Reset properties 395: '----------------- 396: x.Label1.LinkTimeout = 50 397: x.Label1.LinkMode = 0 398: 399: Screen.MousePointer = 0 400: End Sub 401: 402: '---------------------------------------------------------- 403: ' Check for the existence of a file by attempting an OPEN. 404: '---------------------------------------------------------- 405: Function FileExists (path$) As Integer 406: 407: x = FreeFile 408: 409: On Error Resume Next 410: Open path$ For Input As x 411: If Err = 0 Then 412: FileExists = True 413: Else 414: FileExists = False 415: End If 416: Close x 417: 418: End Function 419: 420: '------------------------------------------------ 421: ' Get the disk space free for the current drive 422: '------------------------------------------------ 423: Function GetDiskSpaceFree (drive As String) As Long 424: ChDrive drive 425: GetDiskSpaceFree = DiskSpaceFree() 426: End Function 427: 428: '---------------------------------------------------- 429: ' Get the disk Allocation unit for the current drive 430: '---------------------------------------------------- 431: Function GetDrivesAllocUnit (drive As String) As Long 432: ChDrive drive 433: GetDrivesAllocUnit = AllocUnit() 434: End Function 435: 436: '------------------------ 437: ' Get the size of the file 438: '------------------------ 439: Function GetFileSize (source$) As Long 440: x = FreeFile 441: Open source$ For Binary Access Read As x 442: GetFileSize = LOF(x) 443: Close x 444: End Function 445: 446: Function GetFileVersion (FileToCheck As String) As String 447: On Error Resume Next 448: VersionInfoSize& = GetFileVersionInfoSize(FileToCheck, lpdwHandle&) 449: If VersionInfoSize& = 0 Then 450: GetFileVersion = "" 451: Exit Function 452: End If 453: lpvdata$ = String(VersionInfoSize&, Chr$(0)) 454: VersionInfo% = GetFileVersionInfo(FileToCheck, lpdwHandle&, VersionInfoSize&, lpvdata$) 455: ptrFixed% = VerQueryValue(lpvdata$, "\FILEVERSION", lplpBuffer&, lpcb%) 456: If ptrFixed% = 0 Then 457: ' Take a shot with the hardcoded TransString 458: TransString$ = "040904E4" 459: ptrString% = VerQueryValue(lpvdata$, "\StringFileInfo\" & TransString$ & "\CompanyName", lplpBuffer&, lpcb%) 460: If ptrString% <> 0 Then GoTo GetValues 461: ptrFixed% = VerQueryValue(lpvdata$, "\", lplpBuffer&, lpcb%) 462: If ptrFixed% = 0 Then 463: GetFileVersion = "" 464: Exit Function 465: Else 466: TransString$ = "" 467: fixedstr$ = String(lpcb% + 1, Chr(0)) 468: stringcopy& = lstrcpyn(fixedstr$, lplpBuffer&, lpcb% + 1) 469: For i = lpcb% To 1 Step -1 470: char$ = Hex(Asc(Mid(fixedstr$, i, 1))) 471: If Len(char$) = 1 Then 472: char$ = "0" + char$ 473: End If 474: TransString$ = TransString$ + char$ 475: If Len(TransString$ & nextchar$) Mod 8 = 0 Then 476: TransString$ = "&H" & TransString$ 477: TransValue& = Val(TransString$) 478: TransString$ = "" 479: End If 480: Next i 481: End If 482: End If 483: TransTable$ = String(lpcb% + 1, Chr(0)) 484: TransString$ = String(0, Chr(0)) 485: stringcopy& = lstrcpyn(TransTable$, lplpBuffer&, lpcb% + 1) 486: For i = 1 To lpcb% 487: char$ = Hex(Asc(Mid(TransTable$, i, 1))) 488: If Len(char$) = 1 Then 489: char$ = "0" + char$ 490: End If 491: If Len(TransString$ & nextchar$) Mod 4 = 0 Then 492: nextchar$ = char$ 493: Else 494: TransString$ = TransString$ + char$ + nextchar$ 495: nextchar$ = "" 496: char$ = "" 497: End If 498: Next i 499: GetValues: 500: ptrString% = VerQueryValue(lpvdata$, "\StringFileInfo\" & TransString$ & "\FileVersion", lplpBuffer&, lpcb%) 501: If ptrString% = 1 Then 502: TransTable$ = String(lpcb%, Chr(0)) 503: stringcopy& = lstrcpyn(TransTable$, lplpBuffer&, lpcb% + 1) 504: GetFileVersion = TransTable$ 505: Else 506: GetFileVersion = "" 507: End If 508: End Function 509: 510: '-------------------------------------------------- 511: ' Calls the windows API to get the windows directory 512: '-------------------------------------------------- 513: Function GetWindowsDir () As String 514: temp$ = String$(145, 0) ' Size Buffer 515: x = GetWindowsDirectory(temp$, 145) ' Make API Call 516: temp$ = Left$(temp$, x) ' Trim Buffer 517: 518: If Right$(temp$, 1) <> "\" Then ' Add \ if necessary 519: GetWindowsDir$ = temp$ + "\" 520: Else 521: GetWindowsDir$ = temp$ 522: End If 523: End Function 524: 525: '--------------------------------------------------------- 526: ' Calls the windows API to get the windows\SYSTEM directory 527: '--------------------------------------------------------- 528: Function GetWindowsSysDir () As String 529: temp$ = String$(145, 0) ' Size Buffer 530: x = GetSystemDirectory(temp$, 145) ' Make API Call 531: temp$ = Left$(temp$, x) ' Trim Buffer 532: 533: If Right$(temp$, 1) <> "\" Then ' Add \ if necessary 534: GetWindowsSysDir$ = temp$ + "\" 535: Else 536: GetWindowsSysDir$ = temp$ 537: End If 538: End Function 539: 540: '------------------------------------------------------ 541: ' Function: IsValidPath as integer 542: ' arguments: DestPath$ a string that is a full path 543: ' DefaultDrive$ the default drive. eg. "C:" 544: ' 545: ' If DestPath$ does not include a drive specification, 546: ' IsValidPath uses Default Drive 547: ' 548: ' When IsValidPath is finished, DestPath$ is reformated 549: ' to the format "X:\dir\dir\dir\" 550: ' 551: ' Result: True (-1) if path is valid. 552: ' False (0) if path is invalid 553: '------------------------------------------------------- 554: Function IsValidPath (DestPath$, ByVal DefaultDrive$) As Integer 555: 556: '---------------------------- 557: ' Remove left and right spaces 558: '---------------------------- 559: DestPath$ = RTrim$(LTrim$(DestPath$)) 560: 561: 562: '----------------------------- 563: ' Check Default Drive Parameter 564: '----------------------------- 565: If Right$(DefaultDrive$, 1) <> ":" Or Len(DefaultDrive$) <> 2 Then 566: MsgBox "Bad default drive parameter specified in IsValidPath Function. You passed, """ + DefaultDrive$ + """. Must be one drive letter and "":"". For example, ""C:"", ""D:""...", 64, "Setup Kit Error" 567: GoTo parseErr 568: End If 569: 570: 571: '------------------------------------------------------- 572: ' Insert default drive if path begins with root backslash 573: '------------------------------------------------------- 574: If Left$(DestPath$, 1) = "\" Then 575: DestPath$ = DefaultDrive + DestPath$ 576: End If 577: 578: '----------------------------- 579: ' check for invalid characters 580: '----------------------------- 581: On Error Resume Next 582: tmp$ = Dir$(DestPath$) 583: If Err <> 0 Then 584: GoTo parseErr 585: End If 586: 587: 588: '----------------------------------------- 589: ' Check for wildcard characters and spaces 590: '----------------------------------------- 591: If (InStr(DestPath$, "*") <> 0) GoTo parseErr 592: If (InStr(DestPath$, "?") <> 0) GoTo parseErr 593: If (InStr(DestPath$, " ") <> 0) GoTo parseErr 594: 595: 596: '------------------------------------------ 597: ' Make Sure colon is in second char position 598: '------------------------------------------ 599: If Mid$(DestPath$, 2, 1) <> Chr$(58) Then GoTo parseErr 600: 601: 602: '------------------------------- 603: ' Insert root backslash if needed 604: '------------------------------- 605: If Len(DestPath$) > 2 Then 606: If Right$(Left$(DestPath$, 3), 1) <> "\" Then 607: DestPath$ = Left$(DestPath$, 2) + "\" + Right$(DestPath$, Len(DestPath$) - 2) 608: End If 609: End If 610: 611: '------------------------- 612: ' Check drive to install on 613: '------------------------- 614: drive$ = Left$(DestPath$, 1) 615: ChDrive (drive$) ' Try to change to the dest drive 616: If Err <> 0 Then GoTo parseErr 617: 618: '----------- 619: ' Add final \ 620: '----------- 621: If Right$(DestPath$, 1) <> "\" Then 622: DestPath$ = DestPath$ + "\" 623: End If 624: 625: 626: '------------------------------------- 627: ' Root dir is a valid dir 628: '------------------------------------- 629: If Len(DestPath$) = 3 Then 630: If Right$(DestPath$, 2) = ":\" Then 631: GoTo ParseOK 632: End If 633: End If 634: 635: 636: '------------------------ 637: ' Check for repeated Slash 638: '------------------------ 639: If InStr(DestPath$, "\\") <> 0 Then GoTo parseErr 640: 641: '-------------------------------------- 642: ' Check for illegal directory names 643: '-------------------------------------- 644: legalChar$ = "!#$%&'()-0123456789@ABCDEFGHIJKLMNOPQRSTUVWXYZ^_`{}~.üäöÄÖÜß" 645: BackPos = 3 646: forePos = InStr(4, DestPath$, "\") 647: Do 648: temp$ = Mid$(DestPath$, BackPos + 1, forePos - BackPos - 1) 649: 650: '---------------------------- 651: ' Test for illegal characters 652: '---------------------------- 653: For i = 1 To Len(temp$) 654: If InStr(legalChar$, UCase$(Mid$(temp$, i, 1))) = 0 Then GoTo parseErr 655: Next i 656: 657: '------------------------------------------- 658: ' Check combinations of periods and lengths 659: '------------------------------------------- 660: periodPos = InStr(temp$, ".") 661: length = Len(temp$) 662: If periodPos = 0 Then 663: If length > 8 Then GoTo parseErr ' Base too long 664: Else 665: If periodPos > 9 Then GoTo parseErr ' Base too long 666: If length > periodPos + 3 Then GoTo parseErr ' Extension too long 667: If InStr(periodPos + 1, temp$, ".") <> 0 Then GoTo parseErr' Two periods not allowed 668: End If 669: 670: BackPos = forePos 671: forePos = InStr(BackPos + 1, DestPath$, "\") 672: Loop Until forePos = 0 673: 674: ParseOK: 675: IsValidPath = True 676: Exit Function 677: 678: parseErr: 679: IsValidPath = False 680: End Function 681: 682: '---------------------------------------------------- 683: ' Prompt for the next disk. Use the FileToLookFor$ 684: ' argument to verify that the proper disk, disk number 685: ' wDiskNum, was inserted. 686: '---------------------------------------------------- 687: Function PromptForNextDisk (wDiskNum As Integer, FileToLookFor$) As Integer 688: 689: '------------------------- 690: ' Test for file 691: '------------------------- 692: Ready = False 693: On Error Resume Next 694: temp$ = Dir$(FileToLookFor$) 695: 696: '------------------------ 697: ' If not found, start loop 698: '------------------------ 699: If Err <> 0 Or Len(temp$) = 0 Then 700: While Not Ready 701: Err = 0 702: '---------------------------- 703: ' Put up msg box 704: '---------------------------- 705: Beep 706: x = MsgBox("Please insert disk # " + Format$(wDiskNum%), 49, "SETUP") 707: If x = 2 Then 708: '------------------------------- 709: ' Use hit cancel, abort the copy 710: '------------------------------- 711: PromptForNextDisk = False 712: GoTo ExitProc 713: Else 714: '---------------------------------------- 715: ' User hits OK, try to find the file again 716: '---------------------------------------- 717: temp$ = Dir$(FileToLookFor$) 718: If Err = 0 And Len(temp$) <> 0 Then 719: PromptForNextDisk = True 720: Ready = True 721: End If 722: End If 723: Wend 724: Else 725: PromptForNextDisk = True 726: End If 727: 728: 729: 730: ExitProc: 731: 732: End Function 733: 734: Sub RestoreProgMan () 735: On Error GoTo RestoreProgManErr 736: AppActivate "Program Manager" ' Activate Program Manager. 737: SendKeys "%{ }{Enter}", True ' Send Restore keystrokes. 738: RestoreProgManErr: 739: Exit Sub 740: End Sub 741: 742: '----------------------------------------------------------------------------- 743: ' Set the Destination File's date and time to the Source file's date and time 744: '----------------------------------------------------------------------------- 745: Function SetFileDateTime (SourceFile As String, DestinationFile As String) As Integer 746: x = SetTime(SourceFile, DestinationFile) 747: SetFileDateTime = -1 748: End Function 749: 750: Sub UpdateStatus (FileBytes As Long) 751: '----------------------------------------------------------------------------- 752: ' Update the status bar using form.control Statusdlg.Picture2 753: '----------------------------------------------------------------------------- 754: Static position 755: Dim estTotal As Long 756: 757: estTotal = Val(Statusdlg.total.Tag) 758: If estTotal = False Then 759: estTotal = 10000000 760: End If 761: 762: position = position + CSng((FileBytes / estTotal) * 100) 763: If position > 100 Then 764: position = 100 765: End If 766: Statusdlg.Picture2.Cls 767: Statusdlg.Picture2.Line (0, 0)-((position * (Statusdlg.Picture2.ScaleWidth / 100)), Statusdlg.Picture2.ScaleHeight), QBColor(4), BF 768: 769: Txt$ = Format$(CLng(position)) + "%" 770: Statusdlg.Picture2.CurrentX = (Statusdlg.Picture2.ScaleWidth - Statusdlg.Picture2.TextWidth(Txt$)) \ 2 771: Statusdlg.Picture2.CurrentY = (Statusdlg.Picture2.ScaleHeight - Statusdlg.Picture2.TextHeight(Txt$)) \ 2 772: Statusdlg.Picture2.Print Txt$ 773: 774: r = BitBlt(Statusdlg.Picture1.hDC, 0, 0, Statusdlg.Picture2.ScaleWidth, Statusdlg.Picture2.ScaleHeight, Statusdlg.Picture2.hDC, 0, 0, SRCCOPY) 775: 776: End Sub 777: |