farklı kaydette diğer bilgisayar sorunu

[by_IsTaNBuL]

üstadlarım asagıdaki kendıme uyarladıgım sizin kodlarınızdan biri fakat benim pc de sorunsuz calısıyor hatta 2 bilgisayarımdada sorunsuz calsıyor fakat baska bir bilgisayara mail yoluyla gornderdıgımde çalışmıyor klasor = de hata verıyor
yardımcı olursanız cok sevınecegım
en alttaki karsılama mesajındada baska bılgısayarda hata verıyor. bunu nasıl halledecegım.

aslında söyle bır sorunum var bu dosya sırkette 200-300 kişi tarafından kullanılacak mail yoluyla gönderdiğim zaman excelın hangi versiyonu olura olsun hata vermeden nasıl çalışmasının saglarım . çok önemli arkadaslar yardımlarınızı beklıyorum.
çok tesekkur ederım.



Sub Düğme1_Tıklat()
'
' Düğme1_Tıklat Makro
'

'

Klasor = CreateObject("wscript.Shell").SpecialFolders.Item("Desktop") & "\"
Dosya_Adi = Worksheets("PROF").Range("AW2").Value
Sayfa_Adı = "PROF-MAİL"
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Set Sourcewb = ActiveWorkbook

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Dim wb As Workbook
Set wb = ActiveWorkbook

With wb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else

If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
'MsgBox "HATA VAR"
FileExtStr = Right(Sourcewb.Name, 5)
FileFormatNum = 52
'Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

Dim ds, a
Set ds = CreateObject("Scripting.FileSystemObject")
a = ds.FileExists(Klasor & Dosya_Adi & FileExtStr)
If a = True Then
MsgBox "Bu isimde bir dosya var"
'Exit Sub
Else

Dim sayfa As Worksheet
For Each sayfa In Worksheets
If sayfa.Name = Sayfa_Adı Then
sayfa.Copy
ActiveSheet.Unprotect "pencil"
Range("c1:z172").Select
Selection.Copy
Range("c1").Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Range("c1").Select
Range("ı3:ı171").Select
Selection.AutoFilter
ActiveSheet.Range("$ı$3:$ı$171").AutoFilter Field:=1, Criteria1:=RGB(242, _
242, 242), Operator:=xlFilterCellColor
Range("C4").Select
ActiveSheet.DrawingObjects.Delete

ActiveWorkbook.SaveAs Klasor & Dosya_Adi & FileExtStr, FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False
MsgBox Klasor & Dosya_Adi & FileExtStr & " Dosya kayıt edildi"
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End If

Next
End If
Sheets("PROF-MAİL").Select
Range("C1").Select
Sheets("PROF").Select
Range("C4").Select
End Sub



karsılama mesajı

Private Sub Workbook_Open()
'Space(6) ifadesi kelimeler arasına eşit boşluk vermek için kullanılmaktadır.
'vbCrLf ifadesi boş satır eklemek için kullanılmaktadır.
SATIR_1 = "MERHABA !"
SATIR_2 = "BU SAYFALARDA"
SATIR_3 = "SADECE BEYAZ OLAN"
SATIR_4 = "HÜCRELERİ DEĞİŞTİREBİLİRSİNİZ"
SATIR_5 = "PROGRAM HER AYBAŞI"
SATIR_6 = "GÜNCELLENEREK SİZE MAİL ATILACAKTIR"
SATIR_7 = "MyDesing*M.Emin BAYRAM"
MsgBox SATIR_1 & vbCrLf & vbCrLf & SATIR_2 & vbCrLf & _
SATIR_3 & vbCrLf & SATIR_4 & vbCrLf & SATIR_5 & vbCrLf & SATIR_6 & vbCrLf & SATIR_7 & vbCrLf & vbCrLf & _
"İYİ ÇALIŞMALAR DİLERİM.", vbInformation, "KARŞILAMA MESAJI"
End Sub

 

[hamitcan]

Güvenlik ayarları ile ilgili olabilir mi ?

 

[hamitcan]

Konu ile ilgili aşağıdaki sitede bir açıklama var; burayı da inceleyebilirsiniz.
http://ss64.com/vb/special.html

 

[by_IsTaNBuL]

güvenlik ayarları ilede oynadım ne yaptımsa beceremdım . bu sorunu çözmeme yardım edecek arkadas yokmu acaba ?

 

[hamitcan]

Klasor = CreateObject("wscript.Shell").SpecialFolders.Item( "Desktop") & "\"

yerine aşağıdaki satırı dener misiniz ?

Klasor = CreateObject("wscript.Shell").SpecialFolders( "Desktop") & "\"