exportar vb para web

[razs 0]

Boas pessoal, eu tenho um ficheiro excel com uma macro que ao abrir tem um botao que me permite escolher um ficheiro xml e converte-lo para xls com as formatações necessarias.

 

Alguma hipotese de eu atravez do ASP correr essa macro e fazer a conversao automaticamente?

 

 

Obrigado

[KhaosDoctor 242]

Porque isto está em VB?

[razs 0]

postei aqui porque o codigo da macro é em VB.

 

Esta incorrecto?

[KhaosDoctor 242]

Poste a macro para darmos uma olhada.

[razs 0]

Aqui vai, obrigado.

 

Private Sub DeleteData_Click()
   Application.StatusBar = True
   ' delete Macula exams
   Application.StatusBar = "... deleting"
   Do While Not IsEmpty(Worksheets("mac").Range("A5"))
       Worksheets("mac").Range("A5").EntireRow.Delete Shift:=xlUp
   Loop
   ' delete ONH exams
   Application.StatusBar = "... deleting results"
   Do While Not IsEmpty(Worksheets("oh").Range("A5"))
       Worksheets("oh").Range("A5").EntireRow.Delete Shift:=xlUp
   Loop
   '
   Application.StatusBar = ""
   Application.StatusBar = False
End Sub



Private Sub LoadData_Click()
Dim i As Integer
Dim q As Integer
Dim Pct As Double
'
Dim Rcnt As Integer
Dim Ccnt As Integer
Dim Ptr As Range
'
Dim Quelle As Worksheet
Dim Quelle_NumRow As Integer
Dim Quelle_NumCol As Integer
'
Dim Macula As Worksheet
Dim Macula_Row As Integer
Dim Macula_Col As Integer
Dim ONH As Worksheet
Dim ONH_Row As Integer
Dim ONH_Col As Integer
'
Dim Astr As String
Dim Bstr As String
Dim FName As String
Dim PName As String
Dim Fnum As Integer
Dim FnumSel As Integer
Dim Fcnt As Integer
Dim Fptr As Integer
'
Dim WB As String
Dim MyWB As String
'
Dim PFNames As Variant
Dim PFcopy As Variant
Dim bln As Boolean
'
   Application.ScreenUpdating = False
   Application.StatusBar = True
   MyWB = ActiveWorkbook.Name
   ' detect XML files
   Application.StatusBar = " 0% ... finding XML file(s)"
   Bstr = Worksheets("Load").Range("I1").Value
   PFNames = Application.GetOpenFilename("XML-files, *.xml", , Bstr, , True)
   Astr = TypeName(PFNames)
   If (Astr <> "Boolean") Then
       '
       q = InStrRev(PFNames(1), Application.PathSeparator)
       If q = 0 Then
           PName = ""
       Else
           PName = Left(PFNames(1), q - 1)
           ChDir PName
           '
           For i = 1 To UBound(PFNames)
               PFNames(i) = Mid(PFNames(i), q + 1)
           Next
       End If
       '
       ' How many valid files selected ?
       FnumSel = 0
       For i = 1 To UBound(PFNames)
           Astr = PFNames(i)
           Fcnt = 0
           Do Until Astr = ""
               q = InStr(Astr, "^")
               If q = 0 Then
                   Astr = ""
               Else
                   Fcnt = Fcnt + 1
                   Astr = Mid(Astr, q + 1)
               End If
           Loop
           If Fcnt <> 5 Then
               PFNames(i) = ""
           Else
               FnumSel = FnumSel + 1
           End If
       Next

       ' How many valid files available ?
       Pct = 0
       Fnum = 0
       ' FName = Dir(PName & Application.PathSeparator & "*^*^*^*^*^*.xml")
       FName = Dir("*^*^*^*^*^*.xml")
       Do Until FName = ""
           Fnum = Fnum + 1
           FName = Dir()
       Loop
       '
       If Fnum = FnumSel Then
           If Fnum = 0 Then
               q = MsgBox("No valid xml-file found", 48, "Warning")
               Worksheets("Load").Range("A1").Value = 0    ' cancel
           Else
               Worksheets("Load").Range("A1").Value = 2    ' load all available
           End If
       Else
           LoadOption.Cancel.Caption = Worksheets("Load").Range("K1").Value
           LoadOption.LoadAll.Caption = Worksheets("Load").Range("L1").Value
           LoadOption.LoadSelected.Caption = Worksheets("Load").Range("M1").Value
           Astr = Worksheets("Load").Range("N1").Value & FnumSel & Worksheets("Load").Range("O1").Value
           Astr = Astr & Fnum & Worksheets("Load").Range("P1").Value  ' & FnumSel
           'Astr = Astr & Worksheets("Load").Range("Q1").Value & Fnum & Worksheets("Load").Range("R1").Value
           LoadOption.Label1.Caption = Astr
           '
           LoadOption.Show
       End If
       '
       If Worksheets("Load").Range("A1") > 0 Then
           '
           Set Macula = Worksheets("Macula")
           Set ONH = Worksheets("ONH")
           '
           Fcnt = 0
           If Worksheets("Load").Range("A1") = 2 Then
               ' FName = Dir(PName & Application.PathSeparator & "*^*^*^*^*^*.xml")
               FName = Dir("*^*^*^*^*^*.xml")
           Else
               Fnum = FnumSel
               Fptr = 1
               FName = PFNames(Fptr)
               '
               If FName = "" Then
                   Do Until (FName <> "") Or (Fptr = UBound(PFNames))
                       Fptr = Fptr + 1
                       FName = PFNames(Fptr)
                   Loop
               End If
           End If
           '
           Do Until FName = ""
               Fcnt = Fcnt + 1
               ' Astr = extract patient name
               Application.StatusBar = Int((1 + Pct) * 100 / (Fnum + 1)) & "% ... loading XML file"
               Pct = Pct + 0.5
               Workbooks.OpenXML Filename:=FName, LoadOption:=xlXmlLoadImportToList
               WB = ActiveWorkbook.Name
               Workbooks(MyWB).Activate

               '
               ' load new file into worksheet
               Set Quelle = Workbooks(WB).Worksheets(1)
               Quelle_NumRow = Quelle.UsedRange.Rows.Count - 1
               Quelle_NumCol = Quelle.UsedRange.Columns.Count
               '
               Application.StatusBar = Int((1 + Pct) * 100 / (Fnum + 1)) & "% ... copying Macula-Scan data"
               Pct = Pct + 0.3
               Ccnt = 0
               Do Until IsEmpty(Quelle.Range("A1").Offset(0, Ccnt))
                   Astr = Quelle.Range("A1").Offset(0, Ccnt).Value
                   Select Case Astr
                   Case Is = "ILMRPE", "ILMRPEFIT", "THREEMMCIRCLE", "FIVEMMCIRCLE"
                       i = 1
                       q = 2
                       Do Until IsEmpty(Quelle.Range("A1").Offset(0, Ccnt + i))
                           Bstr = Quelle.Range("A1").Offset(0, Ccnt + i).Value
                           If InStr(Bstr, Astr) > 0 Then
                               Bstr = Right(Bstr, Len(Bstr) - Len(Astr))
                               If IsNumeric(Bstr) Then
                                   Quelle.Range("A1").Offset(0, Ccnt + i).Value = Astr & q
                                   q = q + 1
                               End If
                           End If
                           i = i + 1
                       Loop
                   End Select
                   '
                   Ccnt = Ccnt + 1
               Loop
               '
               ' search for columns in Macula
               '
               Macula_Row = Macula.UsedRange.Rows.Count - 3
               Macula_Col = Macula.UsedRange.Columns.Count
               '
               For Each Ptr In Macula.Range("A4", Range("A4").Offset(0, Macula_Col - 1).Address)
                   Astr = Ptr.Value
                   If Not IsEmpty(Astr) Then
                       For Ccnt = 0 To (Quelle_NumCol - 1)
                           Bstr = Quelle.Range("A1").Offset(0, Ccnt).Value
                           If Astr = Bstr Then
                               For Rcnt = 0 To (Quelle_NumRow - 1)
                                   Ptr.Offset(Macula_Row + Rcnt, 0).Value = Quelle.Range("A2").Offset(Rcnt, Ccnt).Value
                               Next
                               Exit For
                           End If
                       Next
                   End If
               Next
               '
               ' delete ONH exams in Macula list
               '
               Rcnt = 0
               Do While Not IsEmpty(Macula.Range("K4").Offset(Macula_Row + Rcnt, 0))
                   If InStr(Macula.Range("K4").Offset(Macula_Row + Rcnt, 0).Value, "Macular Cube") = 0 Then
                       ' delete line
                       Macula.Range("A4").Offset(Macula_Row + Rcnt, 0).EntireRow.Delete Shift:=xlUp
                   Else
                       ' keep line
                       Rcnt = Rcnt + 1
                   End If
               Loop
               '
               Rcnt = 0
               Do While Not IsEmpty(Macula.Range("A4").Offset(Macula_Row + Rcnt, 0))
                   Rcnt = Rcnt + 1
               Loop
               If Rcnt > 0 Then
                   Astr = Macula.Range("A4").Offset(Macula_Row, 0).Address
                   Bstr = Macula.Range("A4").Offset(Macula_Row, Macula_Col - 2).Address
                   With Macula.Range(Astr, Bstr).Borders(xlEdgeTop)
                       .ColorIndex = 0
                       .LineStyle = xlContinuous
                   End With
               End If
               If Rcnt > 1 Then
                   Astr = Macula.Range("A4").Offset(Macula_Row + 1, 0).Address
                   Bstr = Macula.Range("A4").Offset(Macula_Row + Rcnt - 1, 0).Address
                   Macula.Range(Astr, Bstr).Rows.Group
               End If
               '
               ' search for columns in ONH
               '
               ONH_Row = ONH.UsedRange.Rows.Count - 3
               ONH_Col = ONH.UsedRange.Columns.Count
               '
               Application.StatusBar = Int((1 + Pct) * 100 / (Fnum + 1)) & "% ... copying ONH-Scan data"
               Pct = Pct + 0.2
               For Each Ptr In ONH.Range("A4", Range("A4").Offset(0, ONH_Col - 1).Address)
                   Astr = Ptr.Value
                   If Not IsEmpty(Astr) Then
                       For Ccnt = 0 To (Quelle_NumCol - 1)
                           Bstr = Quelle.Range("A1").Offset(0, Ccnt).Value
                           If Astr = Bstr Then
                               For Rcnt = 0 To (Quelle_NumRow - 1)
                                   Ptr.Offset(ONH_Row + Rcnt, 0).Value = Quelle.Range("A2").Offset(Rcnt, Ccnt).Value
                               Next
                               Exit For
                           End If
                       Next
                   End If
               Next
               '
               ' delete Macula exams in ONH list
               '
               Rcnt = 0
               Do While Not IsEmpty(ONH.Range("K4").Offset(ONH_Row + Rcnt, 0))
                   If InStr(ONH.Range("K4").Offset(ONH_Row + Rcnt, 0).Value, "Optic Disc Cube") = 0 Then
                       ' delete line
                       ONH.Range("A4").Offset(ONH_Row + Rcnt, 0).EntireRow.Delete Shift:=xlUp
                   Else
                       ' keep line
                       Rcnt = Rcnt + 1                 ' keep line
                   End If
               Loop
               '
               Rcnt = 0
               Do While Not IsEmpty(ONH.Range("A4").Offset(ONH_Row + Rcnt, 0))
                   Rcnt = Rcnt + 1
               Loop
               If Rcnt > 0 Then
                   Astr = ONH.Range("A4").Offset(ONH_Row, 0).Address
                   Bstr = ONH.Range("A4").Offset(ONH_Row, ONH_Col - 2).Address
                   With ONH.Range(Astr, Bstr).Borders(xlEdgeTop)
                       .ColorIndex = 0
                       .LineStyle = xlContinuous
                   End With
               End If
               If Rcnt > 1 Then
                   Astr = ONH.Range("A4").Offset(ONH_Row + 1, 0).Address
                   Bstr = ONH.Range("A4").Offset(ONH_Row + Rcnt - 1, 0).Address
                   ONH.Range(Astr, Bstr).Rows.Group
               End If
               '
               ' close the XML file again
               Application.DisplayAlerts = False
               Workbooks(WB).Close
               Application.DisplayAlerts = True
               '
               If Worksheets("Load").Range("A1") = 2 Then
                   FName = Dir()
               Else
                   If Fcnt = Fnum Then     ' DONE
                       FName = ""
                   Else
                       Fptr = Fptr + 1
                       FName = PFNames(Fptr)
                       Do Until (FName <> "") Or (Fptr = UBound(PFNames))
                           Fptr = Fptr + 1
                           FName = PFNames(Fptr)
                       Loop
                   End If
               End If
           Loop
           '
           ActiveWindow.DisplayOutline = True
           Macula.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
           ONH.Outline.ShowLevels RowLevels:=1, ColumnLevels:=1
           '
       End If
   End If
   '
   Application.StatusBar = ""
   Application.StatusBar = False
   Application.ScreenUpdating = True
End Sub