VGnet.dk - Input/Output

Koden anvendes helt på eget ansvar!

Indhold:

Drevbogstav til en fil

Function Drev(ByVal S As String) As String
' (C) Copyright Lars Vangsgaard
  Dim fs
  Set fs = CreateObject("Scripting.FileSystemObject")
  Drev = fs.GetDriveName(S)
  Set fs = Nothing
End Function

Sti til en fil

Function Mappe(ByVal S As String) As String
' (C) Copyright Lars Vangsgaard
  Dim fs, h
  Set fs = CreateObject("Scripting.FileSystemObject")
  If InStr(1, fs.GetFileName(S), ".", vbTextCompare) > 0 Then
    h = fs.GetParentFolderName(S)
    If h <> "" Then h = h & "\"
  Else
    If Right(S, 1) = "\" Then h = S Else h = S & "\"
  End If
  If InStr(1, h, ":", vbTextCompare) = 2 Then
    Mappe = Right(h, Len(h) - 2)
  Else
    Mappe = h
  End If
  Set fs = Nothing
End Function

Navnet på selve filen

Function Fil(ByVal S As String) As String
' (C) Copyright Lars Vangsgaard
  Dim fs, h
  Set fs = CreateObject("Scripting.FileSystemObject")
  h = fs.GetFileName(S)
  If InStr(1, h, ".", vbTextCompare) > 0 Then
    Fil = h
  Else
    Fil = ""
  End If
  Set fs = Nothing
End Function

Skaf en tekstfil til at skrive i

Function SkafTekstfil(Optional Dialogbokstitel As String, Optional Navneforslag As String) As Object
' (C) Copyright Lars Vangsgaard
' Åbner en tekstfil for skrivning.
' I den kaldende procedure bruges en syntaks i stilen
'   Set Udfil = SkafTekstfil(Dialogbokstitel, Navneforslag)
'   Udfil.WriteLine
' Man skal huske at lukke filen igen med
'   Udfil.Close
  Dim svar, fs, f
  If IsMissing(Dialogbokstitel) Then Dialogbokstitel = "Gem som..."
  If IsMissing(Navneforslag) Then Navneforslag = "fil.txt"
  svar = Application.GetSaveAsFilename(Navneforslag, "Alle filer (*.*),*.*", 1, Dialogbokstitel)
  If svar = CStr(False) Then End
  Set fs = CreateObject("Scripting.FileSystemObject")
  If fs.fileexists(svar) Then
    Do Until Not fs.fileexists(svar)
      If vbYes = MsgBox("Filen findes. Vil du overskrive?", vbYesNo) Then
        fs.deletefile svar, True
      Else
        svar = Application.GetSaveAsFilename(Navneforslag, "Alle filer (*.*),*.*", 1, Dialogbokstitel)
        If svar = CStr(False) Then End
      End If
    Loop
  End If
  Set f = fs.CreateTextFile(svar)
  Set SkafTekstfil = f
  Set f = Nothing
  Set fs = Nothing
End Function

Som angivet kan rutinen for eksempel kaldes på følgende måde:

Sub SkrivFil()
' (C) Copyright Lars Vangsgaard
  Dim navn As String, Titel As String, medd As String
  Dim f
  navn = "fil.txt"
' Dummy-filnavn
  Titel = "Gem kommandofil som..."
  Set f = SkafTekstfil(Titel, navn)
' Dummykode begynder her
  f.writeline "Værdi af A1: " & Replace(Format(Range("A1").Value, "0"), ",", ".")
' Dummykode slutter her
  f.Close
  medd = "Filen er skrevet til " & navn & "."
  medd = medd & Chr(13) & Chr(10)
  medd = medd & "Se den eventuelt efter."
  MsgBox medd
  Set f = Nothing
End Sub

Hent et fremmed regneark og kopiér indholdet

Sub NedlastData(fra, til)
' (C) Copyright Lars Vangsgaard
' Åbner et regneark og kopierer indholdet over i et andet regneark.
' Syntaks: f.eks. Call NedlastData("http://www.server.com/folder/bog.xls", "c:\temp\minbog.xls")
  Dim wg, wb, i, Ark
  Workbooks.Open Filename:=fra
  Set wg = ActiveWorkbook
  Workbooks.Add
  Set wb = ActiveWorkbook
  Do While wg.Sheets.Count > wb.Sheets.Count
    wb.Sheets.Add
  Loop
  For i = 1 To wg.Sheets.Count
    Windows(wg.Name).Activate
    wg.Sheets(i).Activate
    Ark = ActiveSheet.Name
    ActiveSheet.UsedRange.Select
    Selection.Copy
    Windows(wb.Name).Activate
    wb.Sheets(i).Activate
    [A1].Activate
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    wb.Sheets(i).Name = Ark
    ActiveSheet.UsedRange.Columns.AutoFit
    [A1].Select
  Next i
  wb.Sheets(1).Activate
  Application.DisplayAlerts = False
  wg.Close
  Windows(wb.Name).Activate
  On Error Resume Next
  ActiveWorkbook.SaveAs Filename:=til ' Eller brug svar = Application.GetSaveAsFilename()
  wb.Close
  On Error GoTo 0
  Application.DisplayAlerts = True
  Set wb = Nothing
  Set wg = Nothing
End Sub

Oversigt over kæder

Sub Linkoversigt()
' (C) Copyright Lars Vangsgaard
  Dim alinks, i
  alinks = ActiveWorkbook.LinkSources(xlExcelLinks)
  If Not IsEmpty(alinks) Then
    For i = 1 To UBound(alinks)
      MsgBox "Link " & i & ":" & Chr(13) & alinks(i)
    Next i
  End If
End Sub

Eksportér modulerne i PERSON.XLS

Sub EksporterPersonModuler()
' (C) Copyright Lars Vangsgaard
  Dim Mappe, modul
  Mappe = SkafMappeNavn("Vælg mappe at gemme i...")
  For Each modul In Workbooks("Person.xls").VBProject.VBComponents
    'MsgBox modul.Name & modul.Type
    'If Left(modul.Name, 5) = "Modul" Then
    If modul.Type = 1 Then
      modul.Export Mappe & "\" & modul.Name & ".bas"
    End If
  Next modul
End Sub

Eksportér modulerne i arbejdsbogen

Sub EksporterArketsModuler()
' (C) Copyright Lars Vangsgaard
  Dim Mappe, Ark, modul
  Mappe = ActiveWorkbook.Path
  If Mappe = "" Then
    Mappe = InputBox("Skriv den mappe, der skal gemmes i...", "Mappenavn", "c:\temp")
    ' Mappe = SkafMappeNavn("Vælg mappe at gemme i...")
  End If
  For Each modul In ActiveWorkbook.VBProject.VBComponents
    'MsgBox modul.Name & modul.Type
    'If Left(modul.Name, 5) = "Modul" Then
    If modul.Type = 1 Then
      modul.Export Mappe & "\" & ActiveWorkbook.Name & "_" & modul.Name & ".bas"
    End If
  Next modul
End Sub

Slet modulerne i arbejdsbogen

Sub SletArketsModuler()
' (C) Copyright Lars Vangsgaard
  Dim modul
  With ActiveWorkbook.VBProject
    For Each modul In .VBComponents
      If modul.Type < 4 Then .VBComponents.Remove .VBComponents(modul.Name)
    Next modul
  End With
End Sub

Siden er oprettet 25-12-2006 og sidst opdateret 14-01-2007 22:53.

█