title image


Smiley so geht's blitzschnell und ist frei konigurierbar


Option Explicit



Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long

Private Declare Function CloseClipboard Lib "user32" () As Long

Private Declare Function OpenClipboard Lib "user32" (ByVal hWnd As Long) As Long

Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Long, ByVal ByteLen As Long)



Private Const RN = "A13:D25 "

Private Const CF_OEMTEXT = 7

Private Const BLATT = "Tabelle1"

Private Const DELIMITER = ","  ' Spaltentrennung

Private Const FILEEXTENTION = ".txt"



' ich habs noch Tabelle 1 genannt ....



Sub schmeisse_Bereich_in_Datei_und_Mache_Textdatei_auf_Desktop()



Dim tmp_str$, fd$(), nm As Variant, i&, Wshshell, pf$, fs, Datei

Set Wshshell = CreateObject("Wscript.Shell")

  nm = InputBox("Filename", "Bitte Dateinamen eingeben ohne Extention")

  If nm = vbNullString Then Exit Sub

  Set fs = CreateObject("Scripting.Filesystemobject")

  Worksheets(BLATT).Range(RN).Copy

  fd = Split(hole_die_Daten_aus_clipboard, vbCrLf)

  Set Datei = fs.CreateTextFile(Wshshell.SpecialFolders("Desktop") & "\" & nm & FILEEXTENTION)

  With Datei

       For i = 0 To UBound(fd)

               .WriteLine Replace(fd(i), Chr(9), DELIMITER)

       Next i

       .Close

   End With

   Set fs = Nothing: Set Datei = Nothing: Erase fd: Set Wshshell = Nothing

End Sub



Private Function hole_die_Daten_aus_clipboard() As String

    

    Dim str_ptr&, Lng&, Bf As String

    OpenClipboard 0

    str_ptr = GetClipboardData(CF_OEMTEXT)

    If str_ptr <> 0 Then

        Lng = lstrlen(str_ptr)

        If Lng > 0 Then

            Bf = Space$(Lng)

            CopyMemory ByVal Bf, ByVal str_ptr, Lng

        End If

    End If

    hole_die_Daten_aus_clipboard = Bf

    CloseClipboard

End Function



 Code eingefügt mit Syntaxhighlighter 1.16

Knofi So wie wir heute arbeiten, werden morgen die Beamten leben ...

geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: