Auto_Open - gem som makro

Hvis du sender en mail til: pb@supertekst-it.dk - så returnere jeg en model, du måske kan anvende.

Private Sub Workbook_Open()
Dim ck As Boolean
    If Right(ThisWorkbook.Name, 3) = "xlt" Then
        If newName = "" Then
            str1 = "Enter New File Name Here"
        Else
            str1 = newName
        End If
        ck = Application.Dialogs(xlDialogSaveAs).Show(str1)
        If ck = True Then
            newName = ActiveWorkbook.Name
        End If
    End If
End Sub

Rem Version 5
Rem =========
Const AarsTalSti = "C:\Documents and Settings\pb\Skrivebord\0903MicRastad\Aarstal.xls"      'tilpasses
Const gemSomSti = "C:\Documents and Settings\pb\Skrivebord\0903MicRastad\Kunder\"          'tilpasses
Const KunderSti = "C:\Documents and Settings\pb\Skrivebord\0903MicRastad\Kunder.xls"        'tilpasses
Const UnderMap1 = "\Regnskaber\"        'UnderMap2 = årsTal

Dim ÅrXLS As Object, kXLS As Object, passFlag As Boolean
Private Sub CommandButton1_Click()          'Gem
    If Me.f_kundeNavn <> "" And Me.f_årsTal <> "" Then
        udførGem
    Else
        MsgBox ("Kundenr. eller årstal ikke udfyldt")
    End If
End Sub
Private Sub udførGem()
Dim sti As String, gemMappe As String, uMappe As String

Rem check drev
    On Error GoTo sti_Fejl

    sti = gemSomSti
    If Right(sti, 1) <> "\" Then
        sti = sti + "\"
    End If
   
Rem Check om "GemMappe" i GemSomStien
    gemMappe = findGemMappe(sti, Me.f_kundeNr)
    If gemMappe = "" Then
        GoTo kundeMappeFindesIkke
    End If

Rem Check om "underMap1" findes til kundeMappen
    gemMappe = gemMappe + UnderMap1
    On Error GoTo opretUnderMappe
    ChDir sti + gemMappe

Rem Check om "underMap2" (årstal) findes til underMap1
    gemMappe = gemMappe + Me.f_årsTal
    On Error GoTo opretUnderMappe
    ChDir sti + gemMappe
   
Rem KundeMappe Ok - gem filen
    On Error GoTo fejlGemSti
    ActiveWorkbook.SaveAs sti + gemMappe + "\" + Me.f_kundeNr + " Regnskab " + Me.f_årsTal + ".xls"

Rem Luk userform
    CommandButton2_Click                            'kan fjernes, hvis lukning ikke ønskes
    Exit Sub

opretUnderMappe:
    MkDir sti + gemMappe
    Resume Next
   
fejlGemSti:
    MsgBox ("Fejl i GemSti - sandsynligvis illegalt tegn i årstal")
    Exit Sub
   
kundeMappeFindesIkke:
    MsgBox ("KundeMappe findes ikke")
    Exit Sub
   
sti_Fejl:
    MsgBox ("Fejl i en sti-angivelse")
End Sub
Private Sub CommandButton2_Click()          'Annuller
    Unload UserForm1
End Sub
Private Sub f_kundeNr_Enter()
    Me.f_kundeNavn = ""
End Sub
Private Sub f_kundeNr_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    If passFlag = False Then
        passFlag = True
        If Me.f_kundeNr <> "" And IsNumeric(Me.f_kundeNr) = True Then
            Me.f_kundeNavn = søgKunde(Val(Me.f_kundeNr))
            If Me.f_kundeNavn <> "" Then
                    Me.f_årsTal.SetFocus
            End If
           
            kXLS.Quit
            Set kXLS = Nothing
        End If
        passFlag = False
    End If
End Sub
Private Sub f_årsTal_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Rem Evt. "/" erstattes af "-" - illegalt tegn

    If Me.f_årsTal <> "" Then
        p = InStr(Me.f_årsTal, "/")
        If p > 0 Then
            Me.f_årsTal = Left(Me.f_årsTal, p - 1) + "-" + Mid(Me.f_årsTal, p + 1)
        End If
    End If
End Sub
Private Function søgKunde(kNr)
    Set kXLS = CreateObject("Excel.application")
    With kXLS
        .Workbooks.Open KunderSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            If .Cells(r, 1) = kNr Then
                søgKunde = .Cells(r, 2)
                Exit Function
            End If
        Next r
    End With
    søgKunde = ""
    MsgBox ("Det indtastede kundenr. kunne ikke findes")
End Function
Private Function findGemMappe(sti, kNr)
Rem Søger efter mappe med navnet: Kundenr+BLANK i begyndelsen af MappeNavnet
    Dim fs, f, f1, fc, s, xKnr
    kNr = CStr(Val(kNr))                            'fjerner foranstillede nuller
   
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.GetFolder(sti)
    Set fc = f.SubFolders
    For Each f1 In fc
        If InStr(f1.Name, kNr + " ") = 1 Or InStr(f1.Name, kNr) = 1 Then
            findGemMappe = f1.Name                  'Fulde mappeNavn returneres..
            Exit Function
        End If
    Next
    findGemMappe = ""
End Function
Private Sub UserForm_activate()
    indlæsÅrstal
   
    Me.f_kundeNr.SetFocus
End Sub
Private Sub indlæsÅrstal()                          'årstal forventes i kolonne 1
    On Error GoTo fejlÅrstalSti
   
    Set ÅrXLS = CreateObject("Excel.application")
    With ÅrXLS
        .Workbooks.Open AarsTalSti
        .Sheets(1).Activate
        Max = .ActiveCell.SpecialCells(xlLastCell).Row
        For r = 1 To Max
            Me.f_årsTal.AddItem .Cells(r, 1)
        Next r
    End With
   
    ÅrXLS.Quit
    Set ÅrXLS = Nothing
    Exit Sub

fejlÅrstalSti:
    MsgBox ("Fejl i sti t/Årstal.xls")
End Sub