VBA macro voor opslaan op USB stick

Status
Niet open voor verdere reacties.
M

maus1602

Gebruiker
Lid geworden
8 mrt 2012
Berichten
14
Goedendag,

Ik heb op mijn USBstick een Excel macro om facturen te maken, op te slaan, nummeren, printen enz.
Deze facturatie tooltje gebruiken ik en mijn zwager, ieder op ons eigen pc

Bestaat er een VBA code die automatisch opslaat op de usb stick, op welke computer de usb stick ook maar ingeplugd is?
Het "Mijnpad" op mijn pc is "G:\
Wanneer de usb stick in de computer mijn zwager zit start deze vanaf locatie "D:\


Option Explicit
'tekst waarmee factuurnummer begint
Const MijnPad = "G:\Facturen\2015\" 'directory waar de facturen staan


Sub factuuropslaan()
Dim Nr As Integer, Pad As String, c1 As String, x As String, Naam As String, i As Integer
Dim Omschr As String
Omschr = "F" & Year(Date) & "-" 'zoek naar factuurnrs van het huidige jaar
Pad = MijnPad & IIf(Right(MijnPad, 1) <> "\", "\", "")
c1 = Dir(Pad & Omschr & "*.xls*") 'zoek xls-files (en xlsm,xlsx, ...) die beginnen met bovenstaande omschrijving
Do Until c1 = "" 'zoeken tot je alle files langsgelopen hebt
x = Replace(c1, Omschr, "") 'verwijder omschrijving
i = InStr(1, x, ".xls") 'nu nog de file-extensie
If i > 0 Then x = Left(x, i - 1)
If IsNumeric(x) Then 'is wat overblijft nog numeric
Nr = WorksheetFunction.Max(Nr, CInt(x)) 'zoek hoogste nummer tot nogtoe
End If
c1 = Dir
Loop

Naam = Omschr & Format(Nr + 1, "000") 'naam van de factuur (voor het geval je max. 999 facturen per jaar maakt

[Invulblad!D13].Value = Naam
ActiveSheet.SaveAs Pad & Naam & ".xls"
'Application.DisplayAlerts = True

' MsgBox "Relatie opslaan"
' Application.Run ("Relatiebeheer")
MsgBox " ** LET OP ** NU GAAN WE PRINTEN ACTIVEREN"
Application.Run ("FactuurPrinten")

Workbooks.Open (Pad & "Origineel factuur.xls")
ThisWorkbook.Close True




End Sub
 
Als eerste, zet je code in Code tags.

Die letter kan je opzoeken met het volgende in een module:
Code: 
Private Declare Function GetDriveType Lib "kernel32" Alias "GetDriveTypeA" _
    (ByVal nDrive As String) As Long

Private Declare Function GetLogicalDriveStrings Lib "kernel32" Alias "GetLogicalDriveStringsA" _
    (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long

Const DRIVE_REMOVABLE = 2

Function StickLetter() As String
    Dim r As Long
    Dim allDrives As String
    Dim JustOneDrive As String
    Dim pos As Long
    Dim DriveType As String
    Dim aronedrive() As String
    
    allDrives = Space(64)
    r = GetLogicalDriveStrings(Len(allDrives), allDrives)
    allDrives = Left(allDrives, r)
    aronedrive = Split(allDrives, vbNullChar)
    For d = UBound(aronedrive) To 1 Step -1
        If GetDriveType(aronedrive(d)) = DRIVE_REMOVABLE Then StickLetter = aronedrive(d): Exit For
    Next
End Function

Dit is dan je test routine:
Code: 
Sub tst()
    MsgBox StickLetter
End Sub

Uiteraard kan je dan geen Const meer voor gebruiken voor Mijnpad.
 
Laatst bewerkt:
Hallo Edmoor,

Wat bedoel je met "Als eerste, zet je code in Code tags."
Ben een beetje een leek die met veel trail and errors toch ergens komt. ;)

Hoe krijg ik jou oplossing werkend in mijn bestaande macro?
 
Wat ik bedoel is dat je als je hier code plaatst, je de code begint met dit:
[ CODE]

En eindigt met:
[ /CODE]

Maar dan zonder spatie achter het [ teken.
De code wordt dan netjes in een kader en een bepaald lettertype getoond zodat het fatsoenlijk leesbaar is.

Hoe het voorbeeld toe te passen:
Plaats de code uit het eerste kader in mijn post in een Module.
Verwijder vervolgens de Const regel uit je code en zet het volgende in je Sub factuuropslaan:
Code: 
    Dim MijnPad As String
    MijnPad = StickLetter & "\Facturen\2015\"               'directory waar de facturen staan

Je Sub factuuropslaan dient er dan als volgt uit te zien:
Code: 
Sub factuuropslaan()
    Dim Nr As Integer
    Dim Pad As String
    Dim c1 As String
    Dim x As String
    Dim Naam As String
    Dim i As Integer
    Dim Omschr As String
    Dim MijnPad As String
    
    MijnPad = StickLetter & "\Facturen\2015\"               'directory waar de facturen staan
    
    Omschr = "F" & Year(Date) & "-"                         'zoek naar factuurnrs van het huidige jaar
    Pad = MijnPad & IIf(Right(MijnPad, 1) <> "\", "\", "")
    c1 = Dir(Pad & Omschr & "*.xls*")                       'zoek xls-files (en xlsm,xlsx, ...) die beginnen met bovenstaande omschrijving
    Do Until c1 = ""                                        'zoeken tot je alle files langsgelopen hebt
        x = Replace(c1, Omschr, "")                         'verwijder omschrijving
        i = InStr(1, x, ".xls")                             'nu nog de file-extensie
        If i > 0 Then x = Left(x, i - 1)
            If IsNumeric(x) Then                            'is wat overblijft nog numeric
            Nr = WorksheetFunction.Max(Nr, CInt(x))         'zoek hoogste nummer tot nogtoe
        End If
        c1 = Dir
    Loop
    
    Naam = Omschr & Format(Nr + 1, "000")                   'naam van de factuur (voor het geval je max. 999 facturen per jaar maakt
    
    [Invulblad!D13].Value = Naam
    ActiveSheet.SaveAs Pad & Naam & ".xls"
    'Application.DisplayAlerts = True
    
    ' MsgBox "Relatie opslaan"
    ' Application.Run ("Relatiebeheer")
    MsgBox " ** LET OP ** NU GAAN WE PRINTEN ACTIVEREN"
    Application.Run ("FactuurPrinten")
    
    Workbooks.Open (Pad & "Origineel factuur.xls")
    ThisWorkbook.Close True
End Sub

Je code heb ik alleen aangepast voor het gebruik van de StickLetter functie.
Verder is deze hetzelfde gebleven en heb ik alleen wat aan de opmaak gedaan.
Je ziet dat het direct een stuk leesbaarder is.
De StickLetter functie werkt goed zolang er maar 1 verwisselbare schijf (stick) op de computer is aangesloten.

Het is trouwens geen "trail and errors" maar "trial and error".
Maar dat terzijde ;)
 
Code: 
Sub M_snb()
   On Error Resume Next
   
   For Each dr In CreateObject("scripting.filesystemobject").drives
     If dr.DriveType = 1 Then MsgBox dr.DriveType & vbLf & dr.driveletter & vbLf & dr.FileSystem
   Next
End Sub
 
Zonder API dus. Kan ook :)
De 1 staat in dit geval voor schijftype Removable.
 
Mooi hoe dat allemaal in z'n werk gaat.

Met een USB stick gaat dat prima. :thumb:
Maar mijn verwisselbare externe harde schijf krijgt dezelfde drivetype als mijn C-schijf (2), mijn D schijf krijgt de waarde 4.
Ik heb er geen verstand van, maar de externe harde schijf is toch een verwijderbaar iets?

Of zit dat dan weer anders?
Ik wil er niet te diep op in gaan, maar het kan nog eens een keer van toepassing zijn.
 
Een externe harde schijf is iets anders dan een USB stick, ook al zijn ze beide op USB aangesloten.

Dit zijn de drive types van de API:
0: Unknown
1: Invalid
2: Removable
3: Fixed
4: Remote (Network)
5: CD Rom
6: Ram Drive

En deze van het FileSystem Object:
0: Unknown
1: Removable
2: Fixed
3: Remote (Network)
4: CD Rom
5: Ram Drive
 
Laatst bewerkt:
Bedankt Ed. :thumb:
 
Hallo Edmoor en snb,

eindelijk weer wat tijd achter de pc, bedankt voor jullie reacties.
Is er geen mogelijkheid om via de macro automatisch op te slaan op het usb stickje? Dus zonder tussenkomst van een popup met info over de dir van de stickletter?


@Edmoor,
ik heb jouw oplossing geprobeerd maar krijg een foutmelding.
Compileerfout, Ongeldig buiten procedure.
Het woord StickLetter wordt gearceerd.

In ieder geval alvast bedankt voor jullie reacties.
Fantastisch om te zien hoe er mee gedacht wordt.

Groet Maurice
 
De geplaatste code is goed dus dan heb je ergens iets niet goed gedaan. Je hebt die functie Stickletter uit #2 toch wel in een module gezet? Plaats anders eens je document.
 
Laatst bewerkt:
Hallo Edmoor,

Voordat we daar meer tijd in gaan steken, even terug naar mijn eerdere vraag :)
"Is er geen mogelijkheid om via de macro automatisch op te slaan op het usb stickje? Dus zonder tussenkomst van een popup met info over de dir van de stickletter?"

Wil niet brutaal zijn hoor, maar zoek eigenlijks iets zonder tussenkomst van een popup info waarmee ik/anderen voor het opslaan steeds de macro moet aanpassen.
 
Een popup is niet nodig. Maar je hebt m'n vraag nog niet beantwoord. Je kan ook de methode van snb gebruiken en aanpassen voor je eigen situatie, dan hoef je niets in een module te doen:
Code: 
On Error Resume Next
For Each dr In CreateObject("scripting.filesystemobject").drives
    If dr.DriveType = 1 Then MijnPad = dr.driveLetter & ":\Facturen\2015\"
Next
On Error GoTo 0
 
Laatst bewerkt:
Top thanks, het is me gelukt.
Werkt als een tierelier.

Bedankt Edmoor en snb
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan