farklı kullanıcıda makro hata veriyor.

[mustafateknetas]

günaydın arkadaşlar.
dosyayı farklı farklı kullanıcıda kayıt yapabilmesi için admin gelen yere ne yazmalıyım ki makro sorun çıkarmasın.
teşekkürler

sup kayit()
ChDir "C:\Documents and Settings\admin\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\admin\Desktop\deneme.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End Sub

 

[halit3]

quote=mustafateknetas;438944]günaydın arkadaşlar.
dosyayı farklı farklı kullanıcıda kayıt yapabilmesi için admin gelen yere ne yazmalıyım ki makro sorun çıkarmasın.
teşekkürler

sup kayit()
ChDir "C:\Documents and Settings\admin\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\admin\Desktop\deneme.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
End Sub[/quote]


bunu denermisiniz.

Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
 
Sub kayit()
Dim Buffer As String * 100
Dim BuffLen As Long
BuffLen = 100
GetUserName Buffer, BuffLen
kullanıcı = Left(Buffer, BuffLen - 1)
ChDir "C:\Documents and Settings\" & kullanıcı & "\Desktop"
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\" & kullanıcı & "\Desktop\deneme.xls", _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWindow.Close
        
End Sub

 

[Korhan Ayhan]

Selamlar,

Daha önce veyselemre beyin başka bir başlıkta kullandığı aşağıdaki kodu denermisiniz.

Option Explicit
 
Sub Farklı_Kaydet()
    Dim Dosya_Yolu As String
    Dosya_Yolu = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & Application.PathSeparator & "Deneme.xls"
    ActiveWorkbook.SaveAs Filename:=Dosya_Yolu
    ActiveWorkbook.Close
End Sub

 

[mustafateknetas]

sayın korhan ve halit bey çok teşekkür ederim

korhan bey
vermiş olduğunuz kodu aşagıdaki takip et yöntemi ile yapmış olduğum kodun içerisine ekledim. çalışıyor fakat
farklı kayıt yaptığımız deneme dosyasının içeriğini resim olarak katıt ediyor
dosya ekleyecektim ama boyut büyükmüş yükleyemedim.

teşekkürler

kod:

Sub cig_kayitt()

Dim Dosya_Yolu As String
Range("A1:BF308").Select
Selection.Copy
Workbooks.Add
Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
ActiveSheet.Buttons.Add(412.5, 6, 120.75, 12).Select
ActiveSheet.Buttons.Add(276, 1.5, 120.75, 15.75).Select
ActiveSheet.Paste
ActiveSheet.Shapes("Düğme 2").Select
Application.CutCopyMode = False
Selection.Cut
ActiveSheet.Shapes("Düğme 1").Select
Selection.Cut
ActiveSheet.PageSetup.PrintArea = "$A$1:$BF$80"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0)
.RightMargin = Application.InchesToPoints(0)
.TopMargin = Application.InchesToPoints(0)
.BottomMargin = Application.InchesToPoints(0)
.HeaderMargin = Application.InchesToPoints(0)
.FooterMargin = Application.InchesToPoints(0)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 200
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = xlPrintErrorsDisplayed
End With
ActiveWindow.SelectedSheets.PrintPreview
Application.CommandBars("Forms").Visible = True
ActiveWindow.DisplayGridlines = False
Application.CommandBars("Forms").Visible = False
Sheets("Sayfa2").Select
ActiveWindow.SelectedSheets.Delete
Sheets("Sayfa3").Select
ActiveWindow.SelectedSheets.Delete
ActiveWindow.Zoom = 85
Dosya_Yolu = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & Application.PathSeparator & "Deneme.xls"
ActiveWorkbook.SaveAs Filename:=Dosya_Yolu
ActiveWorkbook.Close
End Sub

 

[Korhan Ayhan]

Selamlar,

Dosyanızı sıkıştırıp eklemeyi deneyin. Hala boyut büyük uyarısı alırsanız paylaşım sitelerinden birisine ekleyip linkini verebilirsiniz.

 

[mustafateknetas]

sayın korhan bey
sonuç sayfasında iki farklı kaydet butonu ile yeni kitabı yazdırma alanı belerleyip yazdır/kapat onaydan sonra kayıt yapılmasını istiyorum.
teşekkürler