Advertisement
Guest User

Untitled

a guest
Apr 14th, 2014
259
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. Sub Main
  2. Dim xlsFile As Variant
  3. Dim i As Long
  4. Dim img As File
  5. Dim imgs As Files
  6. Dim r As IIMAttribute
  7. Dim k As Integer
  8.  
  9.     On Error GoTo catch
  10.  
  11.     Dim db As Database
  12.     Set db = IMatch.Database
  13.     If db Is Nothing Then
  14.         MsgBox "Please open a database first!"
  15.         Exit Sub
  16.     End If
  17.  
  18.     Dim iset As Files
  19.     Set iset = SelectedFiles
  20.     If iset Is Nothing Then
  21.         MsgBox "Please open a database first!"
  22.         Exit Sub
  23.     End If
  24.  
  25.  
  26.     If iset.Count = 0 Then
  27.         MsgBox "Please open a database first!"
  28.         Exit Sub
  29.     End If
  30.  
  31.     xlsFile = GetFilePath (,"Excel Files|*.xls*", "Choose file", 0)
  32.     If xlsFile = "" Then
  33.         Exit Sub
  34.     End If
  35.  
  36.     Dim oExcelApp   As Excel.Application
  37.     Dim oWs         As Excel.Worksheet
  38.  
  39.     Set oExcelApp = CreateObject("EXCEL.APPLICATION")
  40.     oExcelApp.Visible = False
  41.     oExcelApp.Workbooks.Open FileName:=xlsFile, ReadOnly:=True, ignoreReadOnlyRecommended:=True
  42.     Set oWs = oExcelApp.ActiveSheet
  43.  
  44.  
  45.  
  46.     IMatch.WaitDialogOpen "Importing...",0,oWs.Cells.SpecialCells(xlCellTypeLastCell).Row - 1,True
  47.  
  48.     db.BeginTransaction False
  49.  
  50.     For i = 2 To oWs.Cells.SpecialCells(xlCellTypeLastCell).Row
  51.         IMatch.WaitDialogSetText "Processing " & oWs.Cells(i, 1).Text
  52.         If oWs.Cells(i, 1).Text <> "" Then
  53.             Set img = iset(oWs.Cells(i, 1).Text)
  54.             If sresult <> "" Then
  55.                 sresult = sresult & vbCrLf
  56.             End If
  57.             If Not img Is Nothing Then
  58.                     sResult = sResult & vbCrLf & "** " & oWs.Cells(i, 1).Text & " found in image selection!"
  59.                     Set r = img.Properties
  60.                     k = 2
  61.                     Dim s As String, s2 As String
  62.                     Do Until oWs.Cells(1, k) = ""
  63.                         s = oWs.Cells(1, k)
  64.                         r.Property(s) = oWs.Cells(i, k)
  65.                         k = k + 1
  66.                     Loop
  67.                     r.Update
  68.             Else
  69.                 sResult = sResult & vbCrLf & oWs.Cells(i, 1).Text & " not found in image selecion"
  70.             End If
  71.         End If
  72.         If IMatch.WaitDialogIsCanceled Then
  73.             Exit For
  74.         End If
  75.         IMatch.WaitDialogSetPercentage i
  76.     Next i
  77.  
  78.     db.EndTransaction Not Application.WaitDialogIsCanceled
  79.  
  80.  
  81.     Begin Dialog UserDialog 400,203,"Process Results" ' %GRID:10,7,1,1
  82.         Text 20,7,200,14,"Results:",.Text1
  83.         TextBox 30,28,320,126,.txtResult,1
  84.         OKButton 140,168,120,21
  85.     End Dialog
  86.  
  87.     Dim dlg1 As UserDialog
  88.     If sResult = "" Then
  89.         dlg1.txtResult = "No files."
  90.     Else
  91.         dlg1.txtResult = sResult
  92.     End If
  93.     Dialog dlg1
  94.  
  95.  
  96.     GoTo finally
  97.  
  98. catch:
  99.     MsgBox (Err.Description)
  100.  
  101. finally:
  102.  
  103.     oExcelApp.Quit
  104.     Set oExcelApp = Nothing
  105.  
  106. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement